Permalink
Browse files

Getting to be a fairly acceptable web game.

  • Loading branch information...
1 parent 57bc446 commit 9195ff6f27701abdf1395892b4f6f21c05ce8e7d @clanehin committed Jul 20, 2012
Showing with 1,575 additions and 1,301 deletions.
  1. +0 −1 Roguestar/Lib/BeginGame.hs
  2. +0 −1 Roguestar/Lib/BuildingData.hs
  3. +5 −86 Roguestar/Lib/Character.hs
  4. +1 −1 Roguestar/Lib/CharacterAdvancement.hs
  5. +0 −25 Roguestar/Lib/CharacterData.hs
  6. +1 −16 Roguestar/Lib/CreatureData.hs
  7. +15 −15 Roguestar/Lib/DB.hs
  8. +44 −44 Roguestar/Lib/GridRayCaster.hs
  9. +27 −27 Roguestar/Lib/HierarchicalDatabase.hs
  10. +36 −9 Roguestar/Lib/Perception.hs
  11. +1 −12 Roguestar/Lib/PersistantData.hs
  12. +1 −1 Roguestar/Lib/PlayerState.hs
  13. +0 −785 Roguestar/Lib/Protocol.hs
  14. +91 −11 Roguestar/Lib/Roguestar.hs
  15. +12 −40 Roguestar/Lib/Species.hs
  16. +1 −1 Roguestar/Lib/SpeciesData.hs
  17. +5 −9 Roguestar/Lib/Substances.hs
  18. +6 −6 Roguestar/Lib/ToolData.hs
  19. +139 −31 Roguestar/Server/Main.hs
  20. +325 −0 devnotes/MonsterColors.html
  21. +325 −0 devnotes/TerrainColors.html
  22. +1 −0 feedback/1b6f660f-70e0-4781-a10b-1033c2c23323
  23. +6 −7 roguestar.cabal
  24. +2 −0 snaplets/heist/templates/404.tpl
  25. +49 −19 snaplets/heist/templates/contribute.tpl
  26. +11 −0 snaplets/heist/templates/feedback-thanks.tpl
  27. +16 −0 snaplets/heist/templates/feedback.tpl
  28. +25 −12 snaplets/heist/templates/help.tpl
  29. +10 −8 snaplets/heist/templates/hidden/context.tpl
  30. +0 −11 snaplets/heist/templates/hidden/contribute/artwork.tpl
  31. +0 −1 snaplets/heist/templates/hidden/contribute/haskell.tpl
  32. +0 −5 snaplets/heist/templates/hidden/contribute/other.tpl
  33. +0 −3 snaplets/heist/templates/hidden/contribute/webtalent.tpl
  34. +0 −9 snaplets/heist/templates/hidden/help/keys.tpl
  35. +0 −3 snaplets/heist/templates/hidden/help/wth.tpl
  36. +0 −1 snaplets/heist/templates/hidden/links/contact-me.tpl
  37. +1 −1 snaplets/heist/templates/hidden/links/github.tpl
  38. +10 −3 snaplets/heist/templates/hidden/play/character-creation.tpl
  39. +0 −3 snaplets/heist/templates/hidden/play/context.tpl
  40. +15 −2 snaplets/heist/templates/hidden/play/empty-game.tpl
  41. +10 −0 snaplets/heist/templates/hidden/play/game-over.tpl
  42. +18 −0 snaplets/heist/templates/hidden/play/inventory.tpl
  43. +37 −9 snaplets/heist/templates/hidden/play/{normal-play.tpl → normal.tpl}
  44. +0 −3 snaplets/heist/templates/hidden/ui/faq.tpl
  45. +0 −4 snaplets/heist/templates/hidden/ui/faqbox.tpl
  46. +4 −1 snaplets/heist/templates/index.tpl
  47. +4 −0 static/encyclopedia/species/recreant.txt
  48. +321 −0 static/roguebasic.css
  49. +0 −75 static/roguestar.css
View
1 Roguestar/Lib/BeginGame.hs
@@ -6,7 +6,6 @@ module Roguestar.Lib.BeginGame
import Roguestar.Lib.Plane
import Roguestar.Lib.CreatureData
import Roguestar.Lib.Character
-import Roguestar.Lib.CharacterData
import Roguestar.Lib.BuildingData
import Roguestar.Lib.DB
import Roguestar.Lib.Facing
View
1 Roguestar/Lib/BuildingData.hs
@@ -13,7 +13,6 @@ module Roguestar.Lib.BuildingData
where
import Roguestar.Lib.PowerUpData
-import Roguestar.Lib.CharacterData
import Roguestar.Lib.PersistantData
basic_stargate :: BuildingPrototype
View
91 Roguestar/Lib/Character.hs
@@ -1,98 +1,18 @@
module Roguestar.Lib.Character
- (getEligableCharacterClasses,
- getEligableBaseCharacterClasses,
- applyCharacterClass)
+ (applyCharacterClass)
where
import Roguestar.Lib.Alignment
-import Roguestar.Lib.CharacterData
import Roguestar.Lib.CreatureAttribute
import Roguestar.Lib.CreatureData
import Roguestar.Lib.TerrainData
-
-type Prerequisite = Creature -> Bool
-
-data CharacterClassData = CharacterClassData {
- character_class_prerequisite :: Prerequisite,
- character_class_attributes :: CreatureAttribute }
-
-getEligableCharacterClassesComposable :: [CharacterClass] -> Creature -> [CharacterClass]
-getEligableCharacterClassesComposable allowed_classes creature =
- filter (\x -> character_class_prerequisite (classInfo x) creature || isFavoredClass x creature) allowed_classes
-
-getEligableCharacterClasses :: Creature -> [CharacterClass]
-getEligableCharacterClasses = getEligableCharacterClassesComposable all_character_classes
-
-getEligableBaseCharacterClasses :: Creature -> [CharacterClass]
-getEligableBaseCharacterClasses = getEligableCharacterClassesComposable base_character_classes
-
-prerequisites :: [Prerequisite] -> Prerequisite
-prerequisites prereqs creature = all ($ creature) prereqs
-
-mustHave :: (CreatureScore a) => a -> Integer -> Prerequisite
-mustHave score min_score creature = (rawScore score creature) >= min_score
-
--- |
--- Constructor function for CharacterClassData objects.
---
--- The first parameter should be the prerequisite (or more than one prerequisite using the 'prerequisites'
--- function). The prerequisite(s) restrict what 'Creatures' can advance in the 'CharacterClass'.
---
--- The second parameter is the list of 'CreatureAttribute's that a Creature gains when it levels in the
--- 'CharacterClass'.
---
-characterClass :: Prerequisite -> CreatureAttribute -> CharacterClassData
-characterClass prereqs attribs = CharacterClassData prereqs attribs
+import Roguestar.Lib.PersistantData
applyCharacterClass :: CharacterClass -> Creature -> Creature
-applyCharacterClass character_class creature = applyToCreature (character_class & character_class_attributes (classInfo character_class)) creature
-
-classInfo :: CharacterClass -> CharacterClassData
-
--------------------------------------------------------------------------------
---
--- Base Classes
---
--- These are base classes: these classes have very low prerequisites,
--- with the intention that characters can choose them at the beginning
--- of a game. They also contain extra information about the character's
--- starting equipment and situation.
---
--------------------------------------------------------------------------------
-
-classInfo Barbarian = characterClass (prerequisites [mustHave Strength 15,mustHave Constitution 15]) $
- DamageReductionTrait Melee & DamageReductionTrait Ranged & DamageReductionTrait Unarmed & ToughnessTrait & Speed & Constitution & Strength & Indifferent
-
-classInfo Consular = characterClass (mustHave Charisma 20) $
- Charisma & Diplomatic
-
-classInfo Engineer = characterClass (mustHave Intellect 20) $
- Intellect & Strategic
-
-classInfo ForceAdept = characterClass (prerequisites [mustHave Intellect 15, mustHave Perception 15, mustHave Charisma 15, mustHave Mindfulness 15]) $
- DefenseSkill Ranged & DefenseSkill Melee & AttackSkill Melee & Speed & Perception & Mindfulness & Indifferent
-
-classInfo Marine = characterClass (prerequisites [mustHave Perception 15,mustHave Constitution 15]) $
- AttackSkill Ranged & DefenseSkill Ranged & Constitution & Speed & Perception & Mindfulness & Tactical
-
-classInfo Ninja = characterClass (prerequisites [mustHave Speed 15,mustHave Perception 15]) $
- HideSkill & DefenseSkill Melee & DefenseSkill Ranged & Speed & Indifferent
-
-classInfo Pirate = characterClass (prerequisites [mustHave Strength 10,mustHave Perception 10, mustHave Speed 10, mustHave Charisma 10]) $
- AttackSkill Ranged & ToughnessTrait & Strength & Speed
-
-classInfo Scout = characterClass (prerequisites [mustHave Perception 20]) $
- SpotSkill & Speed & Perception & Tactical
-
-classInfo Shepherd = characterClass (prerequisites [mustHave Charisma 15,mustHave Mindfulness 15]) $
- SpotSkill & TerrainAffinity Grass & Perception & Mindfulness & Indifferent
-
-classInfo Thief = characterClass (mustHave Perception 20) $
- HideSkill & Speed & Charisma & Perception & Tactical
+applyCharacterClass character_class creature = applyToCreature (character_class & classInfo character_class) creature
-classInfo Warrior = characterClass (prerequisites [mustHave Strength 15,mustHave Speed 15]) $
- AttackSkill Melee & DefenseSkill Melee & Constitution & Strength & Speed & Mindfulness & Tactical
+classInfo :: CharacterClass -> CreatureAttribute
-------------------------------------------------------------------------------
--
@@ -102,6 +22,5 @@ classInfo Warrior = characterClass (prerequisites [mustHave Strength 15,mustHave
--
-------------------------------------------------------------------------------
-classInfo StarChild = characterClass (prerequisites []) $
- Intellect & Indifferent
+classInfo StarChild = Mindfulness & Intellect & Perception
View
2 Roguestar/Lib/CharacterAdvancement.hs
@@ -9,8 +9,8 @@ module Roguestar.Lib.CharacterAdvancement
import qualified Data.Map as Map
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.CharacterData
import Roguestar.Lib.PowerUpData
+import Roguestar.Lib.PersistantData
data CharacterBumpResult =
CharacterAwarded { character_points_awarded :: Integer,
View
25 Roguestar/Lib/CharacterData.hs
@@ -1,25 +0,0 @@
-
-module Roguestar.Lib.CharacterData
- (CharacterClass(..),
- all_character_classes,
- base_character_classes)
- where
-
-import Roguestar.Lib.PersistantData
-
-all_character_classes :: [CharacterClass]
-all_character_classes = [minBound..maxBound]
-
-base_character_classes :: [CharacterClass]
-base_character_classes = [Barbarian,
- Consular,
- Engineer,
- ForceAdept,
- Marine,
- Ninja,
- Pirate,
- Scout,
- Shepherd,
- Thief,
- Warrior]
-
View
17 Roguestar/Lib/CreatureData.hs
@@ -7,16 +7,14 @@ module Roguestar.Lib.CreatureData
CreatureAbility(..),
CreatureEndo(..),
CreatureScore(..),
- FavoredClass(..),
CreatureHealth(..),
creatureGender,
creatureHealth,
creatureAbilityScore,
- isFavoredClass,
empty_creature)
where
-import Roguestar.Lib.CharacterData
+import Roguestar.Lib.PersistantData
import Roguestar.Lib.Alignment
import Data.Ratio
import Data.Maybe
@@ -31,7 +29,6 @@ data Creature = Creature { creature_aptitude :: Map.Map CreatureAptitude Integer
creature_ability :: Map.Map CreatureAbility Integer,
creature_ethical :: Map.Map EthicalAlignment Integer,
creature_levels :: Map.Map CharacterClass Integer,
- creature_favored_classes :: Set.Set CharacterClass,
creature_gender :: CreatureGender,
creature_species :: Species,
creature_random_id :: Integer, -- random number attached to the creature, not unique
@@ -48,7 +45,6 @@ empty_creature = Creature {
creature_ability = Map.empty,
creature_ethical = Map.empty,
creature_levels = Map.empty,
- creature_favored_classes = Set.empty,
creature_gender = Neuter,
creature_species = error "empty_creature: undefined creature_species",
creature_random_id = error "empty_creature: undefined creature_random_id",
@@ -140,11 +136,6 @@ instance CreatureEndo CharacterClass where
instance CreatureScore CharacterClass where
rawScore character_class c = fromMaybe 0 $ Map.lookup character_class $ creature_levels c
-newtype FavoredClass = FavoredClass CharacterClass
-
-instance CreatureEndo FavoredClass where
- applyToCreature (FavoredClass favored_class) c = c { creature_favored_classes = Set.insert favored_class $ creature_favored_classes c }
-
-- | Calculator to determine how many ranks a creature has in an ability.
-- Number of aptitude points plus n times number of ability points
figureAbility :: [CreatureAptitude] -> (CreatureAbility,Integer) -> Creature -> Integer
@@ -185,12 +176,6 @@ creatureGender :: Creature -> CreatureGender
creatureGender = creature_gender
-- |
--- Answers true if the specified class is a favored class for this creature.
---
-isFavoredClass :: CharacterClass -> Creature -> Bool
-isFavoredClass character_class creature = character_class `Set.member` (creature_favored_classes creature)
-
--- |
-- Answers the health/injury/maximum health of this creature.
creatureHealth :: Creature -> CreatureHealth
creatureHealth c = result
View
30 Roguestar/Lib/DB.hs
@@ -45,9 +45,9 @@ module Roguestar.Lib.DB
dbAdvanceTime,
dbNextTurn,
dbPushSnapshot,
- dbPeepOldestSnapshot,
- dbPopOldestSnapshot,
- dbHasSnapshot,
+ peepOldestSnapshot,
+ popOldestSnapshot,
+ hasSnapshot,
module Roguestar.Lib.DBData,
module Roguestar.Lib.DBErrorFlag,
module Roguestar.Lib.Random)
@@ -229,8 +229,8 @@ playerState = asks db_player_state
setPlayerState :: PlayerState -> DB ()
setPlayerState state = modify (\db -> db { db_player_state = state })
-getPlayerCreature :: (DBReadable m) => m (Maybe CreatureRef)
-getPlayerCreature = asks db_player_creature
+getPlayerCreature :: (DBReadable m) => m CreatureRef
+getPlayerCreature = liftM (fromMaybe $ error "No player creature selected yet.") $ asks db_player_creature
setPlayerCreature :: CreatureRef -> DB ()
setPlayerCreature creature_ref = modify (\db -> db { db_player_creature = Just creature_ref })
@@ -515,20 +515,20 @@ dbPushSnapshot :: SnapshotEvent -> DB ()
dbPushSnapshot e = modify $ \db -> db {
db_prior_snapshot = Just $ db { db_player_state = SnapshotEvent e } }
-dbPeepOldestSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
-dbPeepOldestSnapshot actionM =
- do m_a <- dbPeepSnapshot $ dbPeepOldestSnapshot actionM
+peepOldestSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
+peepOldestSnapshot actionM =
+ do m_a <- dbPeepSnapshot $ peepOldestSnapshot actionM
maybe actionM return m_a
-dbPopOldestSnapshot :: DB ()
-dbPopOldestSnapshot = modify popOldestSnapshot
+popOldestSnapshot :: DB ()
+popOldestSnapshot = modify popOldestSnapshot_
-dbHasSnapshot :: (DBReadable db) => db Bool
-dbHasSnapshot = liftM isJust $ dbPeepSnapshot (return ())
+hasSnapshot :: (DBReadable db) => db Bool
+hasSnapshot = liftM isJust $ dbPeepSnapshot (return ())
-popOldestSnapshot :: DB_BaseType -> DB_BaseType
-popOldestSnapshot db =
+popOldestSnapshot_ :: DB_BaseType -> DB_BaseType
+popOldestSnapshot_ db =
case isJust $ db_prior_snapshot =<< db_prior_snapshot db of
False -> db { db_prior_snapshot = Nothing }
- True -> db { db_prior_snapshot = fmap popOldestSnapshot $ db_prior_snapshot db }
+ True -> db { db_prior_snapshot = fmap popOldestSnapshot_ $ db_prior_snapshot db }
View
88 Roguestar/Lib/GridRayCaster.hs
@@ -22,42 +22,42 @@ castRays src@(src_x,src_y) dests opacityFn =
List.map (sortBy compareDistance) $ -- sort each group by distance, so the most distant ones come first (then we'll skip the nearer ones if the more distant passes and the nearer is brighter)
groupBy (\ a b -> compareDirection a b == EQ) $ -- order and group the all destinations that lie along the same ray
sortBy (\ a b -> compareDirection a b) dests
- where lengthThenDistance a b = case (length a) `compare` (length b) of
- EQ -> (head b) `compareDistance` (head a)
- ordering -> ordering
- compareDistance ((x1,y1),_) ((x2,y2),_) = compare (abs (x2-src_x) + abs (y2-src_y)) (abs (x1-src_x) + abs (y1-src_y)) -- pairs 1 and 2 deliberately reversed to get reverse sort order
- compareDirection ((x1,y1),_) ((x2,y2),_) | (src_y - y1 == 0) && (src_y - y2 == 0) = signum (src_x-x1) `compare` signum (src_x-x2)
- compareDirection ((_,y1),_) _ | (src_y - y1 == 0) = LT
- compareDirection _ ((_,y2),_) | (src_y - y2 == 0) = GT
- compareDirection ((x1,y1),_) ((x2,y2),_) =
- let slope1 = (src_x-x1)%(src_y-y1)
- slope2 = (src_x-x2)%(src_y-y2)
- in case slope1 `compare` slope2 of
- EQ -> signum (src_y-y1) `compare` signum (src_y-y2)
- ordering -> ordering
- castRays_ _ _ [] = []
- -- in this case: if a more distant ray from a darker spot passes, then the nearer, brighter ray obviously passes (NOT cheating!)
- castRays_ (Just old_brightness) m ((dest,brightness):rest) | brightness >= old_brightness = dest : (castRays_ (Just old_brightness) m rest)
- -- in this case: if two of the three spots near to this spot, but one step further from the observer, pass, then pass this spot (cheating!)
- castRays_ maybe_old_brightness m (((dx,dy),_):rest) | (>= 2) $ length $ List.filter (flip member m) [(dx+signum (dx-src_x),dy),(dx,dy+signum (dy-src_y)),(dx+signum (dx-src_x),dy+signum (dy-src_y))] = (dx,dy) : (castRays_ maybe_old_brightness m rest)
- -- if we don't have a basis to automatically include this spot, then actually cast a ray (expensive!)
- castRays_ maybe_old_brightness m ((dest,brightness):rest) = if castRay src dest brightness opacityFn
- then dest : (castRays_ (Just brightness) m rest)
- else castRays_ maybe_old_brightness m rest
+ where lengthThenDistance a b = case (length a) `compare` (length b) of
+ EQ -> (head b) `compareDistance` (head a)
+ ordering -> ordering
+ compareDistance ((x1,y1),_) ((x2,y2),_) = compare (abs (x2-src_x) + abs (y2-src_y)) (abs (x1-src_x) + abs (y1-src_y)) -- pairs 1 and 2 deliberately reversed to get reverse sort order
+ compareDirection ((x1,y1),_) ((x2,y2),_) | (src_y - y1 == 0) && (src_y - y2 == 0) = signum (src_x-x1) `compare` signum (src_x-x2)
+ compareDirection ((_,y1),_) _ | (src_y - y1 == 0) = LT
+ compareDirection _ ((_,y2),_) | (src_y - y2 == 0) = GT
+ compareDirection ((x1,y1),_) ((x2,y2),_) =
+ let slope1 = (src_x-x1)%(src_y-y1)
+ slope2 = (src_x-x2)%(src_y-y2)
+ in case slope1 `compare` slope2 of
+ EQ -> signum (src_y-y1) `compare` signum (src_y-y2)
+ ordering -> ordering
+ castRays_ _ _ [] = []
+ -- in this case: if a more distant ray from a darker spot passes, then the nearer, brighter ray obviously passes (NOT cheating!)
+ castRays_ (Just old_brightness) m ((dest,brightness):rest) | brightness >= old_brightness = dest : (castRays_ (Just old_brightness) m rest)
+ -- in this case: if two of the three spots near to this spot, but one step further from the observer, pass, then pass this spot (cheating!)
+ castRays_ maybe_old_brightness m (((dx,dy),_):rest) | (>= 2) $ length $ List.filter (flip member m) [(dx+signum (dx-src_x),dy),(dx,dy+signum (dy-src_y)),(dx+signum (dx-src_x),dy+signum (dy-src_y))] = (dx,dy) : (castRays_ maybe_old_brightness m rest)
+ -- if we don't have a basis to automatically include this spot, then actually cast a ray (expensive!)
+ castRays_ maybe_old_brightness m ((dest,brightness):rest) = if castRay src dest brightness opacityFn
+ then dest : (castRays_ (Just brightness) m rest)
+ else castRays_ maybe_old_brightness m rest
-- |
-- Facade function to castRayForOpacity.
--
castRay :: (Integer,Integer) -> (Integer,Integer) -> Integer -> ((Integer,Integer) -> Integer) -> Bool
castRay (ax,ay) (bx,by) brightness opacityFn =
castRayForOpacity (1/8)
- (fromInteger ax,fromInteger ay)
- (fromInteger bx,fromInteger by)
- (fromInteger brightness)
- (integerToFloatOpacityGrid opacityFn)
+ (fromInteger ax,fromInteger ay)
+ (fromInteger bx,fromInteger by)
+ (fromInteger brightness)
+ (integerToFloatOpacityGrid opacityFn)
data Ray = Ray { ray_origin :: !(Float,Float),
- ray_delta :: !(Float,Float) }
+ ray_delta :: !(Float,Float) }
integerToFloatOpacityGrid :: ((Integer,Integer) -> Integer) -> ((Float,Float) -> Float)
integerToFloatOpacityGrid fn (x,y) =
@@ -87,13 +87,13 @@ integerToFloatOpacityGrid fn (x,y) =
castRayForOpacity :: Float -> (Float,Float) -> (Float,Float) -> Float -> ((Float,Float)->Float) -> Bool
castRayForOpacity fineness a@(ax,ay) b@(bx,by) brightness rawOpacityFn =
let ray = setRayLength fineness $ rayFromTo a b
- opacityFn = \ x -> (1 - rawOpacityFn x / 100) ** fineness
- lengthSquared (x1,y1) (x2,y2) = (x1-x2)^2 + (y1-y2)^2
- goal_length = minimum $ List.map (lengthSquared a) [(bx - signum (bx-ax),by),(bx,by - signum (by-ay)),(bx - signum (bx-ax),by + signum (by-ay))]
- in all (> 1) $
- scanl (\ bright pt -> bright * opacityFn pt) brightness $
- takeWhile ( \ pt -> lengthSquared a pt < goal_length) $
- rayToPoints ray
+ opacityFn = \ x -> (1 - rawOpacityFn x / 100) ** fineness
+ lengthSquared (x1,y1) (x2,y2) = (x1-x2)^2 + (y1-y2)^2
+ goal_length = minimum $ List.map (lengthSquared a) [(bx - signum (bx-ax),by),(bx,by - signum (by-ay)),(bx - signum (bx-ax),by + signum (by-ay))]
+ in all (> 1) $
+ scanl (\ bright pt -> bright * opacityFn pt) brightness $
+ takeWhile ( \ pt -> lengthSquared a pt < goal_length) $
+ rayToPoints ray
-- |
-- Generates a ray from the first point through the second point.
@@ -107,8 +107,8 @@ rayFromTo (ax,ay) (bx,by) = Ray (ax,ay) (bx-ax,by-ay)
setRayLength :: Float -> Ray -> Ray
setRayLength new_distance ray@(Ray { ray_delta=(dx,dy) }) =
let old_distance = sqrt $ (dx^2 + dy^2)
- scalar = new_distance/old_distance
- in ray { ray_delta=(scalar*dx,scalar*dy) }
+ scalar = new_distance/old_distance
+ in ray { ray_delta=(scalar*dx,scalar*dy) }
-- |
-- Advances a ray by its ray_delta.
@@ -132,24 +132,24 @@ gridRayCasterTests = [easyRayTest,hardRayTest,tooHardRayTest,stressLazyRayTest]
easyRayTest :: TestCase
easyRayTest = (if castRay (4,5) (-3,-1) 100 sampleDensityFunction
- then return (Passed "easyRayTest")
- else return (Failed "easyRayTest"))
+ then return (Passed "easyRayTest")
+ else return (Failed "easyRayTest"))
hardRayTest :: TestCase
hardRayTest = (if castRay (10,0) (0,10) 5 sampleDensityFunction
- then return (Passed "hardRayTest")
- else return (Failed "hardRayTest"))
+ then return (Passed "hardRayTest")
+ else return (Failed "hardRayTest"))
tooHardRayTest :: TestCase
tooHardRayTest = (if castRay (10,0) (0,10) 4 sampleDensityFunction
- then return (Failed "tooHardRayTest")
- else return (Passed "tooHardRayTest"))
+ then return (Failed "tooHardRayTest")
+ else return (Passed "tooHardRayTest"))
-- |
-- This test should evaluate quickly, even though the ray is very long, because the ray
-- will be opaqued early the casting of the ray.
--
stressLazyRayTest :: TestCase
stressLazyRayTest = (if castRay (-1,0) (1,2500000) 2 sampleDensityFunction
- then return (Failed "stressLazyRayTest")
- else return (Passed "stressLazyRayTest"))
+ then return (Failed "stressLazyRayTest")
+ else return (Passed "stressLazyRayTest"))
View
54 Roguestar/Lib/HierarchicalDatabase.hs
@@ -100,8 +100,8 @@ lookupParent x the_map = fst $ lookup x the_map
--
childrenOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [Integer]
childrenOf x the_map = maybe [] id $ Map.lookup x (hd_children the_map)
-
-
+
+
-- |
-- Converts a HierarchicalDatabase into a list of relations.
--
@@ -123,46 +123,46 @@ instance HierarchicalRelation ExampleRelation where
example1 :: HierarchicalDatabase ExampleRelation
example1 = fromList $ List.map ExampleRelation
[(1,13,True),
- (1,(-5),True),
- (1,1,True),
- (1,7,True),
- (1,15,True),
- (2,0,False),
- (3,12,True),
- (3,9,False),
- (3,(-3),True),
- (4,100,False),
- (4,(-6),False),
- (4,14,False)]
+ (1,(-5),True),
+ (1,1,True),
+ (1,7,True),
+ (1,15,True),
+ (2,0,False),
+ (3,12,True),
+ (3,9,False),
+ (3,(-3),True),
+ (4,100,False),
+ (4,(-6),False),
+ (4,14,False)]
testParent :: TestCase
testParent = if (parentOf 0 example1) == (Just 2)
- then return (Passed "testParent")
- else return (Failed "testParent")
+ then return (Passed "testParent")
+ else return (Failed "testParent")
testChildren :: TestCase
testChildren = if (length $ childrenOf 1 example1) == 5
- then return (Passed "testChildren")
- else return (Failed "testChildren")
+ then return (Passed "testChildren")
+ else return (Failed "testChildren")
testUserData :: TestCase
testUserData = let child_records = lookupChildren 1 example1
- in if (all (\(ExampleRelation (_,_,b)) -> b) child_records)
- then return (Passed "testUserDatas")
- else return (Failed "testUserDatas")
+ in if (all (\(ExampleRelation (_,_,b)) -> b) child_records)
+ then return (Passed "testUserDatas")
+ else return (Failed "testUserDatas")
testChildrenCorrect :: TestCase
testChildrenCorrect = let the_children = childrenOf 4 example1
- in if (all even the_children)
- then return (Passed "testChildrenCorrect")
- else return (Failed "testChildrenCorrect")
+ in if (all even the_children)
+ then return (Passed "testChildrenCorrect")
+ else return (Failed "testChildrenCorrect")
testDelete :: TestCase
testDelete = let deleted = delete 0 $ delete (-6) $ example1
- in if ((length $ childrenOf 4 deleted) == 2 &&
- (isNothing $ parentOf 0 deleted))
- then return (Passed "testDelete")
- else return (Failed "testDelete")
+ in if ((length $ childrenOf 4 deleted) == 2 &&
+ (isNothing $ parentOf 0 deleted))
+ then return (Passed "testDelete")
+ else return (Failed "testDelete")
insidenessTests :: [TestCase]
insidenessTests = [testParent,testChildren,testUserData,testChildrenCorrect,testDelete]
View
45 Roguestar/Lib/Perception.hs
@@ -3,16 +3,20 @@
-- | The Perception monad is a wrapper for roguestar's core
-- monad that reveals only as much information as a character
-- legitimately has. Thus, it is suitable for writing AI
--- routines as well as an API for the player's client.
+-- routines as well as an API for the human player's client.
module Roguestar.Lib.Perception
(DBPerception,
whoAmI,
runPerception,
VisibleObject(..),
+ isVisibleTool,
+ isVisibleCreature,
+ isVisibleBuilding,
stackVisibleObjects,
visibleObjects,
visibleTerrain,
myFaction,
+ myInventory,
Roguestar.Lib.Perception.getCreatureFaction,
whereAmI,
Roguestar.Lib.Perception.whereIs,
@@ -46,11 +50,11 @@ import Roguestar.Lib.Building
import Roguestar.Lib.SpeciesData
import qualified Data.ByteString.Char8 as B
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.CharacterData
import qualified Data.Set as Set
import qualified Data.Map as Map
import Roguestar.Lib.Tool
import Roguestar.Lib.ToolData
+import Roguestar.Lib.PersistantData
import qualified Roguestar.Lib.DetailedTravel as DT
newtype (DBReadable db) => DBPerception db a = DBPerception { fromPerception :: (ReaderT CreatureRef db a) }
@@ -93,37 +97,54 @@ visibleTerrain =
data VisibleObject =
VisibleTool {
+ visible_tool_ref :: ToolRef,
visible_tool :: Tool,
visible_object_position :: Position }
| VisibleCreature {
+ visible_creature_ref :: CreatureRef,
visible_creature_species :: Species,
visible_creature_character_classes :: [CharacterClass],
- visible_creature_wielding :: Maybe Tool,
+ visible_creature_wielding :: Maybe VisibleObject,
visible_object_position :: Position,
visible_creature_faction :: Faction }
| VisibleBuilding {
+ visible_building_ref :: BuildingRef,
visible_building_shape :: BuildingShape,
visible_building_occupies :: MultiPosition,
visible_object_position :: Position }
-convertToVisibleObjectRecord :: (DBReadable db) => Reference () -> db VisibleObject
+isVisibleTool :: VisibleObject -> Bool
+isVisibleTool (VisibleTool {}) = True
+isVisibleTool _ = False
+
+isVisibleCreature :: VisibleObject -> Bool
+isVisibleCreature (VisibleCreature {}) = True
+isVisibleCreature _ = False
+
+isVisibleBuilding :: VisibleObject -> Bool
+isVisibleBuilding (VisibleBuilding {}) = True
+isVisibleBuilding _ = False
+
+convertToVisibleObjectRecord :: (DBReadable db) => Reference a -> db VisibleObject
convertToVisibleObjectRecord ref | (Just creature_ref) <- coerceReference ref =
do species <- liftM creature_species $ dbGetCreature creature_ref
classes <- liftM (Map.keys . creature_levels) $ dbGetCreature creature_ref
faction <- Creature.getCreatureFaction creature_ref
m_tool_ref <- getWielded creature_ref
+ position <- liftM detail $ DT.whereIs creature_ref
m_wielded <- case m_tool_ref of
- Just tool_ref -> liftM Just $ dbGetTool tool_ref
+ Just tool_ref ->
+ do tool <- dbGetTool tool_ref
+ return $ Just $ VisibleTool tool_ref tool position
Nothing -> return Nothing
- position <- liftM detail $ DT.whereIs creature_ref
- return $ VisibleCreature species classes m_wielded position faction
+ return $ VisibleCreature creature_ref species classes m_wielded position faction
convertToVisibleObjectRecord ref | (Just tool_ref) <- coerceReference ref =
do tool <- dbGetTool tool_ref
position <- liftM detail $ getPlanarLocation tool_ref
- return $ VisibleTool tool position
+ return $ VisibleTool tool_ref tool position
convertToVisibleObjectRecord ref | (Just building_ref :: Maybe BuildingRef) <- coerceReference ref =
do location <- DT.whereIs building_ref
- return $ VisibleBuilding (detail location) (detail location) (detail location)
+ return $ VisibleBuilding building_ref (detail location) (detail location) (detail location)
stackVisibleObjects :: [VisibleObject] -> Map Position [VisibleObject]
stackVisibleObjects = foldr insertVob Map.empty
@@ -161,6 +182,12 @@ visibleObjects filterF =
Nothing -> return []
liftDB $ mapRO convertToVisibleObjectRecord visible_objects
+myInventory :: (DBReadable db) => DBPerception db [VisibleObject]
+myInventory =
+ do me <- whoAmI
+ (result :: [DetailedLocation Inventory]) <- liftDB $ liftM mapLocations $ DB.getContents me
+ liftDB $ mapRO convertToVisibleObjectRecord $ sortBy (comparing toUID) $ (asChildren result :: [ToolRef])
+
myFaction :: (DBReadable db) => DBPerception db Faction
myFaction = Roguestar.Lib.Perception.getCreatureFaction =<< whoAmI
View
13 Roguestar/Lib/PersistantData.hs
@@ -11,18 +11,7 @@ module Roguestar.Lib.PersistantData
{----- CHARACTER -----}
-data CharacterClass = Barbarian
- | Consular
- | Engineer
- | ForceAdept
- | Marine
- | Ninja
- | Pirate
- | Scout
- | Shepherd
- | StarChild
- | Thief
- | Warrior
+data CharacterClass = StarChild
deriving (Eq,Enum,Bounded,Read,Show,Ord)
{----- POWER UPS -----}
View
2 Roguestar/Lib/PlayerState.hs
@@ -6,9 +6,9 @@ module Roguestar.Lib.PlayerState
import Roguestar.Lib.DBData
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.CharacterData
import Roguestar.Lib.MakeData
import Roguestar.Lib.TravelData
+import Roguestar.Lib.PersistantData
data PlayerState =
SpeciesSelectionState (Maybe Creature)
View
785 Roguestar/Lib/Protocol.hs
@@ -1,785 +0,0 @@
-{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, OverloadedStrings #-}
-
-module Protocol
- (mainLoop)
- where
-
-import Prelude hiding (getContents)
-import Data.Char
-import Reference
-import Data.List as List
-import CreatureData
-import Creature
-import Character
-import DB
-import System.Exit
-import System.IO hiding (getContents)
-import BeginGame
-import Data.Maybe
-import Plane
-import PlaneData
-import Building
-import BuildingData
-import Tool
-import FactionData
-import PlaneVisibility
-import Facing
-import ToolData
-import Control.Monad.Error
-import Turns
-import SpeciesData
-import Species
-import Data.Ord
-import Combat
-import Substances
-import PlayerState
-import Make
-import Control.Concurrent
-import Control.Monad.STM
-import Control.Concurrent.STM.TVar
-import Control.Exception
-import WorkCluster
-import qualified Data.ByteString.Char8 as B
-import qualified Perception
-import DetailedLocation
--- Don't call dbBehave, use dbPerformPlayerTurn
-import Behavior hiding (dbBehave)
--- We need to construct References based on UIDs, so we cheat a little:
-import DBPrivate (Reference(ToolRef))
-
-mainLoop :: DB_BaseType -> IO ()
-mainLoop db_init =
- do db_var <- newMVar db_init
- input_chan <- newChan
- output_chan <- newChan
- query_count <- newTVarIO (Just 0) -- Just (the number of running queries) or Nothing (a non-query action is in progress)
- wait_quit <- newEmptyMVar
- work_cluster <- newWorkCluster
- replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var
- let foreverLoopThenQuit = flip finally (putMVar wait_quit ()) . forever
- _ <- forkIO $ foreverLoopThenQuit $ writeChan input_chan =<< B.getLine --read loop
- _ <- forkIO $ foreverLoopThenQuit $ --write loop
- do next_line <- liftM (B.map toLower . B.unlines . B.lines) (readChan output_chan)
- when (B.length next_line > 0) $
- do B.putStrLn next_line
- B.putStrLn "over"
- hFlush stdout
- _ <- forkIO $ foreverLoopThenQuit $
- -- read and dispatch commands, querys are run predictively
- -- (before they are actually received) and in parallel
- do next_command <- readChan input_chan
- case (B.words $ B.map toLower next_command) of
- ["quit"] -> exitWith ExitSuccess
- ["reset"] -> stopping query_count $ modifyMVar_ db_var (const $ return initial_db)
- ("game":"query":args) ->
- do querrying query_count $
- do result <- workRequest work_cluster (Query, args)
- complete Nothing output_chan result
- ("game":"action":args) ->
- do result <- workRequest work_cluster (Action, args)
- stopping query_count $ complete (Just db_var) output_chan result
- querrying query_count $ complete Nothing output_chan result -- print the result as a query, this will ensure errors get printed
- replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var
- ("noop":_) -> return ()
- failed ->
- do _ <- forkIO $ complete Nothing output_chan $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ B.unpack (B.unwords failed) ++ "`"
- return ()
- takeMVar wait_quit -- "park" the main function
-
--- | Evaluate a 'GameDirective' and return it from a remote thread via an 'MVar'.
-evaluateGame :: DB_BaseType -> WorkRequest -> IO WorkResult
-evaluateGame db0 (Query, ["snapshot"]) = (runDB $ ro $ liftM (\b -> "answer: snapshot " `B.append` if b then "yes" else "no") dbHasSnapshot) db0
-evaluateGame db0 (Query, args) = (runDB $ ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0
-evaluateGame db0 (Action, args) = runDB (liftM (const "") $ dbDispatchAction args) db0
-
--- | Wait for currently running queries to finish, and stop processing incomming queries while we mutate the database.
-stopping :: TVar (Maybe Integer) -> IO () -> IO ()
-stopping query_count actionM = bracket
- (atomically $ do maybe retry (\x -> when (x /= 0) retry) =<< readTVar query_count
- writeTVar query_count $ Nothing)
- (const $ atomically $ writeTVar query_count (Just 0))
- (const actionM)
-
--- | Process a querry concurrently with other queries.
-querrying :: TVar (Maybe Integer) -> IO () -> IO ()
-querrying query_count actionM =
- do atomically $ writeTVar query_count =<< liftM Just . (maybe retry $ return . (+1)) =<< readTVar query_count
- _ <- forkIO $ finally (atomically $ do writeTVar query_count =<< liftM (fmap (subtract 1)) (readTVar query_count)) actionM
- return ()
-
--- | Complete a querry or action. If a database variable is provided, it will be modified according to the result of the action.
--- The result of the action will be printed to the output_chan.
-complete :: Maybe (MVar DB_BaseType) -> Chan B.ByteString -> Either DBError (B.ByteString,DB_BaseType) -> IO ()
-complete m_db_var output_chan result =
- do case m_db_var of
- Just db_var ->
- do modifyMVar_ db_var $ \db0 -> return $ case result of
- Right (_,db1) -> db1
- Left (DBErrorFlag errflag) -> db0 { db_error_flag = show errflag }
- Left (DBError _) -> db0
- writeChan output_chan "done"
- Nothing ->
- do case result of
- Right (outstr,_) ->
- do _ <- evaluate outstr
- writeChan output_chan outstr
- Left (DBErrorFlag _) -> return () -- client will query this explicitly (if it cares)
- Left (DBError errstr) ->
- do writeChan output_chan $ "error: " `B.append` B.pack errstr
- B.hPutStrLn stderr $ "DBError: " `B.append` B.pack errstr
-
-dbOldestSnapshotOnly :: (DBReadable db) => db ()
-dbOldestSnapshotOnly =
- do b <- dbHasSnapshot
- when b $ fail "protocol-error: pending snapshot"
-
--- |
--- Perform an action assuming the database is in the DBRaceSelectionState,
--- otherwise returns an error message.
---
-dbRequiresSpeciesSelectionState :: (DBReadable db) => db a -> db a
-dbRequiresSpeciesSelectionState action =
- do dbOldestSnapshotOnly
- state <- playerState
- case state of
- SpeciesSelectionState -> action
- _ -> throwError $ DBError $ "protocol-error: not in species selection state (" ++ show state ++ ")"
-
--- |
--- Perform an action assuming the database is in the DBClassSelectionState,
--- otherwise returns an error message.
---
-dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db a) -> db a
-dbRequiresClassSelectionState action =
- do dbOldestSnapshotOnly
- state <- playerState
- case state of
- ClassSelectionState creature -> action creature
- _ -> throwError $ DBError $ "protocol-error: not in class selection state (" ++ show state ++ ")"
-
--- |
--- Perform an action that operates on the player creature (not in any context).
--- The states that work for this are:
---
--- * ClassSelectionState
--- * PlayerCreatureTurn
---
-dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db a) -> db a
-dbRequiresPlayerCenteredState action =
- do dbOldestSnapshotOnly
- state <- playerState
- case state of
- ClassSelectionState creature -> action creature
- PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref
- _ -> throwError $ DBError $ "protocol-error: not in player-centered state (" ++ show state ++ ")"
-
--- |
--- Perform an action that works during any creature's turn in a planar environment.
--- The states that work for this are:
---
--- * PlayerCreatureTurn
--- * SnapshotEvent
---
-dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a
-dbRequiresPlanarTurnState action =
- do dbOldestSnapshotOnly
- state <- playerState
- maybe (throwError $ DBError $ "protocol-error: not in planar turn state (" ++ show state ++ ")") action $ creatureOf state
-
--- |
--- Perform an action that works only during a player-character's turn.
--- The states that work for this are:
---
--- PlayerCreatureTurn
---
-dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a
-dbRequiresPlayerTurnState action =
- do dbOldestSnapshotOnly
- state <- playerState
- case state of
- PlayerCreatureTurn creature_ref _ -> action creature_ref
- _ -> throwError $ DBError $ "protocol-error: not in player turn state (" ++ show state ++ ")"
-
--- |
--- For arbitrary-length menu selections, get the current index into the menu, if any.
---
-menuState :: (DBReadable db) => db (Maybe Integer)
-menuState = liftM menuIndex playerState
-
--- |
--- For arbitrary-length menu selections, modify the current index into the menu. If there is no menu index
--- in the current state, this has no effect.
---
-modifyMenuState :: (Integer -> Integer) -> DB ()
-modifyMenuState f_ =
- do number_of_tools <- liftM genericLength toolMenuElements
- let f = (\x -> if number_of_tools == 0 then 0 else x `mod` number_of_tools) . f_
- setPlayerState . modifyMenuIndex f =<< playerState
-
-dbDispatchQuery :: (DBReadable db) => [B.ByteString] -> db B.ByteString
-dbDispatchQuery ["state"] =
- do state <- playerState
- return $ case state of
- SpeciesSelectionState -> "answer: state species-selection"
- ClassSelectionState {} -> "answer: state class-selection"
- PlayerCreatureTurn _ NormalMode -> "answer: state player-turn"
- PlayerCreatureTurn _ MoveMode -> "answer: state move"
- PlayerCreatureTurn _ (PickupMode {}) -> "answer: state pickup"
- PlayerCreatureTurn _ (DropMode {}) -> "answer: state drop"
- PlayerCreatureTurn _ (WieldMode {}) -> "answer: state wield"
- PlayerCreatureTurn _ AttackMode -> "answer: state attack"
- PlayerCreatureTurn _ FireMode -> "answer: state fire"
- PlayerCreatureTurn _ JumpMode -> "answer: state jump"
- PlayerCreatureTurn _ TurnMode -> "answer: state turn"
- PlayerCreatureTurn _ (MakeMode _ make_prep) | isFinished make_prep -> "answer: state make-finished"
- PlayerCreatureTurn _ (MakeMode _ make_prep) | needsKind make_prep -> "answer: state make-what"
- PlayerCreatureTurn _ (MakeMode {}) -> "answer: state make"
- PlayerCreatureTurn _ ClearTerrainMode -> "answer: state clear-terrain"
- SnapshotEvent (AttackEvent {}) -> "answer: state attack-event"
- SnapshotEvent (MissEvent {}) -> "answer: state miss-event"
- SnapshotEvent (KilledEvent {}) -> "answer: state killed-event"
- SnapshotEvent (WeaponOverheatsEvent {}) -> "answer: state weapon-overheats-event"
- SnapshotEvent (WeaponExplodesEvent {}) -> "answer: state weapon-explodes-event"
- SnapshotEvent (DisarmEvent {}) -> "answer: state disarm-event"
- SnapshotEvent (SunderEvent {}) -> "answer: state sunder-event"
- SnapshotEvent (TeleportEvent {}) -> "answer: state teleport-event"
- SnapshotEvent (HealEvent {}) -> "answer: state heal-event"
- SnapshotEvent (ClimbEvent {}) -> "answer: state climb-event"
- SnapshotEvent (ExpendToolEvent {}) -> "answer: state expend-tool-event"
- SnapshotEvent (BumpEvent {}) -> "answer: state bump-event"
- GameOver -> "answer: state game-over"
-
-dbDispatchQuery ["action-count"] =
- do n <- dbActionCount
- return $ "answer: action-count " `B.append` (B.pack $ show n)
-
-dbDispatchQuery ["menu-state"] =
- do m_state <- menuState
- return $ case m_state of
- Nothing -> "answer: menu-state 0"
- Just state -> "answer: menu-state " `B.append` (B.pack $ show state)
-
-dbDispatchQuery ["who-attacks"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
- SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
- SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
- SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
- SnapshotEvent (DisarmEvent { disarm_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
- SnapshotEvent (SunderEvent { sunder_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
- _ -> "answer: who-attacks 0"
-
-dbDispatchQuery ["who-hit"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
- SnapshotEvent (DisarmEvent { disarm_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
- SnapshotEvent (SunderEvent { sunder_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
- _ -> "answer: who-hit 0"
-
-dbDispatchQuery ["tool-used"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent (ExpendToolEvent { expend_tool_event_tool = tool_ref }) -> "answer: tool-used " `B.append` (B.pack $ show $ toUID tool_ref)
- _ -> "answer: tool-used 0"
-
-dbDispatchQuery ["weapon-used"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
- SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
- SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
- SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
- SnapshotEvent (SunderEvent { sunder_event_source_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
- _ -> "answer: weapon-used 0"
-
-dbDispatchQuery ["tool-hit"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent (DisarmEvent { disarm_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)
- SnapshotEvent (SunderEvent { sunder_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)
- _ -> "answer: tool-hit 0"
-
-dbDispatchQuery ["who-killed"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " `B.append` (B.pack $ show $ toUID killed_ref)
- _ -> "answer: who-killed 0"
-
-dbDispatchQuery ["who-event"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent event -> "answer: who-event " `B.append` fromMaybe "0" (fmap (B.pack . show . toUID) $ subjectOf event)
- _ -> "answer: who-event 0"
-
-dbDispatchQuery ["new-level"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent event -> "answer: new-level " `B.append` maybe "nothing" (B.pack . show) (bump_event_new_level event)
- _ -> "answer: new-level nothing"
-
-dbDispatchQuery ["new-character-class"] =
- do state <- playerState
- return $ case state of
- SnapshotEvent event -> "answer: new-character-class " `B.append` maybe "nothing" (B.pack . show) (bump_event_new_class event)
- _ -> "answer: new-character-class nothing"
-
-dbDispatchQuery ["player-species","0"] =
- return ("begin-table player-species 0 name\n" `B.append`
- B.unlines (map B.pack player_species_names) `B.append`
- "end-table")
-
-dbDispatchQuery ["visible-terrain","0"] =
- do maybe_plane_ref <- dbGetCurrentPlane
- terrain_map <- maybe (return []) (dbGetVisibleTerrainForFaction Player) maybe_plane_ref
- return ("begin-table visible-terrain 0 x y terrain-type\n" `B.append`
- (B.unlines $ map (\(terrain_type,Position (x,y)) -> B.unwords $ map B.pack [show x, show y, show terrain_type]) terrain_map) `B.append`
- "end-table")
-
-dbDispatchQuery ["who-player"] = return "answer: who-player 2"
-
-dbDispatchQuery ["visible-objects","0"] =
- do maybe_plane_ref <- dbGetCurrentPlane
- (objects :: [Reference ()]) <- maybe (return [])
- (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref
- table_rows <- mapM dbObjectToTableRow objects
- return ("begin-table visible-objects 0 object-unique-id x y facing\n" `B.append`
- (B.unlines $ table_rows) `B.append`
- "end-table")
- where dbObjectToTableRow obj_ref =
- do l <- whereIs obj_ref
- return $ case (fromLocation l,fromLocation l) of
- (Just (Position (x,y)),maybe_face) -> B.unwords $ map B.pack $ [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]
- _ -> ""
-
-dbDispatchQuery ["object-details",uid] = ro $
- do maybe_plane_ref <- dbGetCurrentPlane
- (visibles :: [Reference ()]) <- maybe
- (return [])
- (dbGetVisibleObjectsForFaction (\ref ->
- do let f = (== uid) . B.pack . show . toUID
- let m_wielder = coerceReference ref
- m_wield <- maybe (return Nothing) getWielded m_wielder
- return $ maybe False f m_wield || f ref) Player)
- maybe_plane_ref
- let (creature_refs :: [CreatureRef]) = mapMaybe coerceReference visibles
- wielded <- liftM catMaybes $ mapM getWielded creature_refs
- let (tool_refs :: [ToolRef]) = mapMaybe coerceReference visibles ++ wielded
- let (building_refs :: [BuildingRef]) = mapMaybe coerceReference visibles
- creatures <- liftM (zip creature_refs) $ mapRO dbGetCreature creature_refs
- tools <- liftM (zip tool_refs) $ mapRO dbGetTool tool_refs
- buildings <- liftM (zip building_refs) $ mapRO dbGetBuilding building_refs
- liftM B.unlines $ liftM3 (\a b c -> concat [a,b,c])
- (mapM creatureToTableData creatures)
- (mapM toolToTableData tools)
- (mapM buildingToTableData buildings)
- where objectTableWrapper :: (DBReadable db) =>
- Reference a ->
- db B.ByteString ->
- db B.ByteString
- objectTableWrapper obj_ref tableDataF =
- do table_data <- tableDataF
- return $
- "begin-table object-details " `B.append`
- (B.pack $ show $ toUID obj_ref) `B.append`
- " property value\n" `B.append`
- table_data `B.append`
- "end-table"
- creatureToTableData :: (DBReadable db) =>
- (CreatureRef,Creature) ->
- db B.ByteString
- creatureToTableData (ref,creature) = objectTableWrapper ref $
- do fac <- getCreatureFaction ref
- hp <- getCreatureAbsoluteHealth ref
- maxhp <- getCreatureMaxHealth ref
- return $
- "object-type creature\n" `B.append`
- "species " `B.append` (B.pack $ show $ creature_species creature) `B.append` "\n" `B.append`
- "random-id " `B.append` (B.pack $ show $ creature_random_id creature) `B.append` "\n" `B.append`
- "faction " `B.append` B.pack (show fac) `B.append` "\n" `B.append`
- (if fac == Player then
- "hp " `B.append` B.pack (show hp) `B.append` "\n" `B.append`
- "maxhp " `B.append` B.pack (show maxhp) `B.append` "\n"
- else "")
- toolToTableData :: (DBReadable db) => (ToolRef,Tool) -> db B.ByteString
- toolToTableData (ref,tool) = objectTableWrapper ref $ return $
- "object-type tool\n" `B.append`
- "tool-type " `B.append` toolType tool `B.append` "\n" `B.append`
- "tool " `B.append` toolName tool `B.append` "\n"
- buildingToTableData :: (DBReadable db) => (BuildingRef,Building) -> db B.ByteString
- buildingToTableData (ref,Building {}) = objectTableWrapper ref $
- do building_shape <- buildingShape ref
- return $ "object-type building\n" `B.append`
- "building-shape " `B.append` B.pack (show building_shape) `B.append` "\n"
-
-dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats
-
-dbDispatchQuery ["center-coordinates","0"] = dbRequiresPlanarTurnState dbQueryCenterCoordinates
-
-dbDispatchQuery ["base-classes","0"] = dbRequiresClassSelectionState dbQueryBaseClasses
-
-dbDispatchQuery ["pickups","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
- liftM (showToolMenuTable "pickups" "0") $ toolsToMenuTable =<< availablePickups creature_ref
-
-dbDispatchQuery ["inventory","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
- do inventory <- liftM (map asChild . mapLocations) $ getContents creature_ref
- liftM (showToolMenuTable "inventory" "0") $ toolsToMenuTable inventory
-
-dbDispatchQuery ["menu","0"] =
- liftM (showToolMenuTable "menu" "0") $ toolsToMenuTable =<< toolMenuElements
-
-dbDispatchQuery ["menu",s] | Just window_size <- readNumber s =
- do -- constructs a scrolling window of menu items
- -- FIXME! This should be done client side.
- n <- liftM (fromMaybe 0) menuState
- l <- menuLength
- let half_window = window_size `div` 2
- let window_top = max 0 $ min (l-window_size-1) (n - half_window)
- let windowFilter (x,_,_) = x >= window_top && x <= window_top + window_size
- liftM (showToolMenuTable "menu" s . filter windowFilter) $ toolsToMenuTable =<< toolMenuElements
-
-dbDispatchQuery ["wielded-objects","0"] =
- do m_plane_ref <- dbGetCurrentPlane
- visible_refs <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) m_plane_ref
- let (creature_refs :: [CreatureRef]) = mapMaybe coerceReference visible_refs
- wielded_tool_refs <- mapM getWielded creature_refs
- let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe B.ByteString
- wieldedPairToTable creature_ref = fmap (\tool_ref -> (B.pack $ show $ toUID tool_ref) `B.append` " " `B.append` (B.pack $ show $ toUID creature_ref))
- return $ "begin-table wielded-objects 0 uid creature\n" `B.append`
- B.unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) `B.append`
- "end-table"
-
-dbDispatchQuery ["biome"] =
- do m_plane_ref <- dbGetCurrentPlane
- biome_name <- case m_plane_ref of
- Nothing -> return "nothing"
- Just plane_ref -> liftM (show . plane_biome) $ dbGetPlane plane_ref
- return $ "answer: biome " `B.append` B.pack biome_name
-
-dbDispatchQuery ["current-plane"] =
- do m_plane_ref <- dbGetCurrentPlane
- return $ case m_plane_ref of
- Nothing -> "answer: current-plane 0"
- Just plane_ref -> "answer: current-plane " `B.append` (B.pack $ show $ toUID plane_ref)
-
-dbDispatchQuery ["plane-random-id"] =
- do m_plane_ref <- dbGetCurrentPlane
- case m_plane_ref of
- Nothing -> return "answer: plane-random-id 0"
- Just plane_ref -> liftM (("answer: plane-random-id " `B.append`) . B.pack . show . plane_random_id) $ dbGetPlane plane_ref
-
-dbDispatchQuery ["planet-name"] =
- do m_plane_ref <- dbGetCurrentPlane
- case m_plane_ref of
- Nothing -> return "answer: planet-name nothing"
- Just plane_ref -> liftM ("answer: planet-name " `B.append`) $ planetName plane_ref
-
-dbDispatchQuery ["compass"] =
- do m_player_ref <- getCurrentCreature Player
- case m_player_ref of
- Nothing -> return "answer: compass nothing"
- Just player_ref -> Perception.runPerception player_ref $ liftM (("answer: compass " `B.append`) . B.pack . show) Perception.compass
-
-dbDispatchQuery ["dungeon-depth"] =
- do m_player_ref <- getCurrentCreature Player
- case m_player_ref of
- Nothing -> return "answer: compass nothing"
- Just player_ref -> Perception.runPerception player_ref $ liftM (("answer: dungeon-depth " `B.append`) . B.pack . show) Perception.depth
-
-dbDispatchQuery unrecognized = return $ "protocol-error: unrecognized query `" `B.append` B.unwords unrecognized `B.append` "`"
-
------------------------------------------------------
--- Actions
------------------------------------------------------
-
-dbDispatchAction :: [B.ByteString] -> DB ()
-dbDispatchAction ["continue"] = dbPopOldestSnapshot
-
-dbDispatchAction ["select-species",species_name] =
- dbRequiresSpeciesSelectionState $ dbSelectPlayerRace species_name
-
-dbDispatchAction ["reroll"] =
- dbRequiresClassSelectionState $ dbRerollSpecies
-
-dbDispatchAction ["select-class",class_name] =
- dbRequiresClassSelectionState $ dbSelectPlayerClass class_name
-
-dbDispatchAction [direction] | isJust $ stringToFacing direction =
- do state <- playerState
- case state of
- PlayerCreatureTurn _ player_mode -> case player_mode of
- JumpMode -> dbDispatchAction ["jump",direction]
- TurnMode -> dbDispatchAction ["turn",direction]
- AttackMode -> dbDispatchAction ["attack",direction]
- FireMode -> dbDispatchAction ["fire",direction]
- MoveMode -> dbDispatchAction ["move",direction]
- ClearTerrainMode -> dbDispatchAction ["clear-terrain",direction]
- _ -> dbDispatchAction ["normal",direction]
- _ -> throwError $ DBError $ "protocol-error: not in player turn state"
-
-dbDispatchAction ["normal"] =
- dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref NormalMode)
-
-dbDispatchAction ["normal",direction] | Just face <- stringToFacing direction =
- dbRequiresPlayerTurnState $ \creature_ref ->
- do behavior <- facingBehavior creature_ref face
- dbPerformPlayerTurn behavior creature_ref
-
-dbDispatchAction ["move"] =
- dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref MoveMode)
-
-dbDispatchAction ["move",direction] | isJust $ stringToFacing direction =
- dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Step $ fromJust $ stringToFacing direction) creature_ref)
-
-dbDispatchAction ["jump"] =
- dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref JumpMode)
-
-dbDispatchAction ["jump",direction] | isJust $ stringToFacing direction =
- dbRequiresPlayerTurnState (\creature_ref -> dbPerformPlayerTurn (Behavior.Jump $ fromJust $ stringToFacing direction) creature_ref)
-
-dbDispatchAction ["turn"] =
- dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref TurnMode)
-
-dbDispatchAction ["turn",direction] | isJust $ stringToFacing direction =
- dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (TurnInPlace $ fromJust $ stringToFacing direction) creature_ref
-
-dbDispatchAction ["clear-terrain"] =
- dbRequiresPlayerTurnState $ \creature_ref -> (setPlayerState $ PlayerCreatureTurn creature_ref ClearTerrainMode)
-
-dbDispatchAction ["clear-terrain",direction] | isJust $ stringToFacing direction =
- dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (ClearTerrain $ fromJust $ stringToFacing direction) creature_ref
-
-dbDispatchAction ["next"] = modifyMenuState (+1)
-
-dbDispatchAction ["prev"] = modifyMenuState (subtract 1)
-
-dbDispatchAction ["select-menu"] =
- do state <- playerState
- i <- menuState
- tool_table <- toolsToMenuTable =<< toolMenuElements
- let selection = maybe "0" (\(_,tool_ref,_) -> B.pack $ show $ toUID tool_ref) $ find (\(n,_,_) -> Just n == i) tool_table
- case state of
- PlayerCreatureTurn _ player_mode -> case player_mode of
- PickupMode {} -> dbDispatchAction ["pickup",selection]
- DropMode {} -> dbDispatchAction ["drop",selection]
- WieldMode {} -> dbDispatchAction ["wield",selection]
- MakeMode {} -> dbDispatchAction ["make-with",selection]
- _ -> throwError $ DBError $ "protocol-error: not in menu selection state"
- _ -> throwError $ DBError $ "protocol-error: not in player turn state"
-
-dbDispatchAction ["make-begin"] = dbRequiresPlayerTurnState $ \creature_ref ->
- setPlayerState (PlayerCreatureTurn creature_ref (MakeMode 0 prepare_make))
-
-dbDispatchAction ["make-what",what] | (Just device_kind) <- readDeviceKind what =
- do state <- playerState
- case state of
- PlayerCreatureTurn c (MakeMode n make_prep) -> (setPlayerState $ PlayerCreatureTurn c $ MakeMode n (make_prep `makeWith` device_kind))
- _ -> throwError $ DBError $ "protocol-error: not in make or make-what state"
-
-dbDispatchAction ["make-with",tool_uid] =
- do tool_ref <- readUID ToolRef tool_uid
- tool <- dbGetTool tool_ref
- state <- playerState
- case state of
- PlayerCreatureTurn c (MakeMode _ make_prep) -> case (hasChromalite tool, hasMaterial tool, hasGas tool) of
- (Just ch,_,_) | needsChromalite make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (ch,tool_ref))
- (_,Just m,_) | needsMaterial make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (m,tool_ref))
- (_,_,Just g) | needsGas make_prep -> setPlayerState (PlayerCreatureTurn c $ MakeMode 0 $ make_prep `makeWith` (g,tool_ref))
- _ | otherwise -> throwError $ DBError "error: tool doesn't have needed substance"
- _ -> throwError $ DBError "protocol-error: not in make or make-what state"
-
-dbDispatchAction ["make-end"] =
- do state <- playerState
- case state of
- PlayerCreatureTurn c (MakeMode _ make_prep) | isFinished make_prep -> dbPerformPlayerTurn (Make make_prep) c
- PlayerCreatureTurn _ (MakeMode {}) -> throwError $ DBError "protocol-error: make isn't complete"
- _ -> throwError $ DBError "protocol-error: not in make or make-what state"
-
-dbDispatchAction ["pickup"] = dbRequiresPlayerTurnState $ \creature_ref ->
- do pickups <- availablePickups creature_ref
- case pickups of
- [tool_ref] -> dbPerformPlayerTurn (Pickup tool_ref) creature_ref >> return ()
- [] -> throwError $ DBErrorFlag NothingAtFeet
- _ -> setPlayerState (PlayerCreatureTurn creature_ref (PickupMode 0))
-
-dbDispatchAction ["pickup",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
- do tool_ref <- readUID ToolRef tool_uid
- dbPerformPlayerTurn (Pickup tool_ref) creature_ref
-
-dbDispatchAction ["drop"] = dbRequiresPlayerTurnState $ \creature_ref ->
- do inventory <- liftM (map asChild . mapLocations) $ getContents creature_ref
- case inventory of
- [tool_ref] -> dbPerformPlayerTurn (Drop tool_ref) creature_ref >> return ()
- [] -> throwError $ DBErrorFlag NothingInInventory
- _ -> setPlayerState (PlayerCreatureTurn creature_ref (DropMode 0))
-
-dbDispatchAction ["drop",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
- do tool_ref <- readUID ToolRef tool_uid
- dbPerformPlayerTurn (Drop tool_ref) creature_ref
-
-dbDispatchAction ["wield"] = dbRequiresPlayerTurnState $ \creature_ref ->
- do available <- availableWields creature_ref
- case available of
- [tool_ref] -> dbPerformPlayerTurn (Wield tool_ref) creature_ref >> return ()
- [] -> throwError $ DBErrorFlag NothingInInventory
- _ -> setPlayerState (PlayerCreatureTurn creature_ref (WieldMode 0))
-
-dbDispatchAction ["wield",tool_uid] = dbRequiresPlayerTurnState $ \creature_ref ->
- do tool_ref <- readUID ToolRef tool_uid
- dbPerformPlayerTurn (Wield tool_ref) creature_ref
-
-dbDispatchAction ["unwield"] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn Unwield creature_ref
-
-dbDispatchAction ["fire"] =
- dbRequiresPlayerTurnState $ \creature_ref -> rangedAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref FireMode)
-
-dbDispatchAction ["fire",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Fire $ fromJust $ stringToFacing direction) creature_ref
-
-dbDispatchAction ["attack"] =
- dbRequiresPlayerTurnState $ \creature_ref -> meleeAttackModel creature_ref >> setPlayerState (PlayerCreatureTurn creature_ref AttackMode)
-
-dbDispatchAction ["attack",direction] = dbRequiresPlayerTurnState $ \creature_ref -> dbPerformPlayerTurn (Attack $ fromJust $ stringToFacing direction) creature_ref
-
-dbDispatchAction ["activate"] = dbRequiresPlayerTurnState $ dbPerformPlayerTurn Activate
-
-dbDispatchAction ["down"] =
- dbRequiresPlayerTurnState $ dbPerformPlayerTurn StepDown
-
-dbDispatchAction ["up"] =
- dbRequiresPlayerTurnState $ dbPerformPlayerTurn StepUp
-
-dbDispatchAction unrecognized = throwError $ DBError $ ("protocol-error: unrecognized action `" ++ (B.unpack $ B.unwords unrecognized) ++ "`")
-
-dbSelectPlayerRace :: B.ByteString -> DB ()
-dbSelectPlayerRace species_name =
- case find (\s -> B.map toLower (B.pack $ show s) == species_name) player_species of
- Nothing -> throwError $ DBError $ "protocol-error: unrecognized species '" ++ B.unpack species_name ++ "'"
- Just species -> generateInitialPlayerCreature species
-
-dbSelectPlayerClass :: B.ByteString -> Creature -> DB ()
-dbSelectPlayerClass class_name creature =
- let eligable_base_classes = getEligableBaseCharacterClasses creature
- in case find (\x -> (B.map toLower . B.pack . show) x == class_name) eligable_base_classes of
- Nothing -> throwError $ DBError $ "protocol-error: unrecognized or invalid class '" ++ B.unpack class_name ++ "'"
- Just the_class -> dbBeginGame creature the_class
-
-dbRerollSpecies :: Creature -> DB ()
-dbRerollSpecies _ = do starting_species <- dbGetStartingSpecies
- generateInitialPlayerCreature $ fromJust starting_species
-
-dbQueryPlayerStats :: (DBReadable db) => Creature -> db B.ByteString
-dbQueryPlayerStats creature = return $ playerStatsTable creature
-
--- |
--- Generate a list of tools, e.g. for an inventory list or pickup list.
--- The data source is selected on a context-sensitive basis.
---
-toolMenuElements :: (DBReadable db) => db [ToolRef]
-toolMenuElements =
- do state <- playerState
- case state of
- PlayerCreatureTurn c (PickupMode {}) -> availablePickups c
- PlayerCreatureTurn c (WieldMode {}) -> availableWields c
- PlayerCreatureTurn c (MakeMode _ make_prep) | needsChromalite make_prep -> filterM (liftM (isJust . hasChromalite) . dbGetTool) =<< availableWields c
- PlayerCreatureTurn c (MakeMode _ make_prep) | needsMaterial make_prep -> filterM (liftM (isJust . hasMaterial) . dbGetTool) =<< availableWields c
- PlayerCreatureTurn c (MakeMode _ make_prep) | needsGas make_prep -> filterM (liftM (isJust . hasGas) . dbGetTool) =<< availableWields c
- PlayerCreatureTurn c _ -> liftM (map asChild . mapLocations) $ getContents c
- _ -> return []
-
--- |
--- Convert a list of tool menu elements into table row entries.
--- The result entries consist of an index incrementing from zero, ToolRef, and name of the tool.
---
-toolsToMenuTable :: (DBReadable db) => [ToolRef] -> db [(Integer,ToolRef,B.ByteString)]
-toolsToMenuTable raw_uids =
- do let uids = sortBy (comparing toUID) raw_uids
- tool_names <- mapM (liftM toolName . dbGetTool) uids
- return $ zip3 [0..] uids tool_names
-
-menuLength :: (DBReadable db) => db Integer
-menuLength = liftM genericLength toolMenuElements
-
--- |
--- Generate a tool menu table in text form, with the specified name and element list.
---
-showToolMenuTable :: B.ByteString -> B.ByteString -> [(Integer,ToolRef,B.ByteString)] -> B.ByteString
-showToolMenuTable table_name table_id tool_table =
- "begin-table " `B.append` table_name `B.append` " " `B.append` table_id `B.append` " n uid name" `B.append` "\n" `B.append`
- B.unlines (map (\(n,uid,tool_name) -> B.unwords [B.pack $ show n,B.pack $ show $ toUID uid,tool_name]) tool_table) `B.append`
- "end-table"
-
--- |
--- Information about player creatures (for which the player should have almost all available information.)
---
-playerStatsTable :: Creature -> B.ByteString
-playerStatsTable c =
- "begin-table player-stats 0 property value\n" `B.append`
- "str " `B.append` (B.pack $ show $ rawScore Strength c) `B.append` "\n" `B.append`
- "spd " `B.append` (B.pack $ show $ rawScore Speed c) `B.append` "\n" `B.append`
- "con " `B.append` (B.pack $ show $ rawScore Constitution c) `B.append` "\n" `B.append`
- "int " `B.append` (B.pack $ show $ rawScore Intellect c) `B.append` "\n" `B.append`
- "per " `B.append` (B.pack $ show $ rawScore Perception c) `B.append` "\n" `B.append`
- "cha " `B.append` (B.pack $ show $ rawScore Charisma c) `B.append` "\n" `B.append`
- "mind " `B.append` (B.pack $ show $ rawScore Mindfulness c) `B.append` "\n" `B.append`
- "maxhp " `B.append` (B.pack $ show $ creatureAbilityScore ToughnessTrait c) `B.append` "\n" `B.append`
- "species " `B.append` (B.pack $ show $ creature_species c) `B.append` "\n" `B.append`
- "random-id " `B.append` (B.pack $ show $ creature_random_id c) `B.append` "\n" `B.append`
- "gender " `B.append` (B.pack $ show $ creatureGender c) `B.append` "\n" `B.append`
- "end-table"
-
-toolName :: Tool -> B.ByteString
-toolName (DeviceTool _ d) = deviceName d
-toolName (Sphere s) = prettySubstance s
-
-toolType :: Tool -> B.ByteString
-toolType (DeviceTool Gun _) = "gun"
-toolType (DeviceTool Sword _) = "sword"
-toolType (Sphere (GasSubstance _)) = "sphere-gas"
-toolType (Sphere (MaterialSubstance _)) = "sphere-material"
-toolType (Sphere (ChromaliteSubstance _)) = "sphere-chromalite"
-
-dbQueryBaseClasses :: (DBReadable db) => Creature -> db B.ByteString
-dbQueryBaseClasses creature = return $ baseClassesTable creature
-
-baseClassesTable :: Creature -> B.ByteString
-baseClassesTable creature =
- "begin-table base-classes 0 class\n" `B.append`
- (B.unlines $ map (B.pack . show) $ getEligableBaseCharacterClasses creature) `B.append`
- "end-table"
-
-dbQueryCenterCoordinates :: (DBReadable db) => CreatureRef -> db B.ByteString
-dbQueryCenterCoordinates creature_ref =
- do l <- whereIs creature_ref
- case (fromLocation l,fromLocation l :: Maybe Facing) of
- (Just (Position (x,y)),Nothing) ->
- return (begin_table `B.append`
- "x " `B.append` B.pack (show x) `B.append` "\n" `B.append`
- "y " `B.append` B.pack (show y) `B.append` "\n" `B.append`
- "end-table")
- (Just (Position (x,y)),Just face) ->
- return (begin_table `B.append`
- "x " `B.append` B.pack (show x) `B.append` "\n" `B.append`
- "y " `B.append` B.pack (show y) `B.append` "\n" `B.append`
- "facing " `B.append` B.pack (show face) `B.append` "\n" `B.append`
- "end-table")
- _ -> return (begin_table `B.append` "end-table")
- where begin_table = "begin-table center-coordinates 0 axis coordinate\n"
-
-readUID :: (Integer -> Reference a) -> B.ByteString -> DB (Reference a)
-readUID f x =
- do let m_uid = readNumber x
- ok <- maybe (return False) (dbVerify . f) m_uid
- when (not ok) $ throwError $ DBError $ "protocol-error: " ++ B.unpack x ++ " is not a valid uid."
- return $ f $ fromJust m_uid
-
-readNumber :: B.ByteString -> Maybe Integer
-readNumber = fmap fst . B.readInteger
-
-readDeviceKind :: B.ByteString -> Maybe DeviceKind
-readDeviceKind "pistol" = Just Pistol
-readDeviceKind "carbine" = Just Carbine
-readDeviceKind "rifle" = Just Rifle
-readDeviceKind "fleuret" = Just Fleuret
-readDeviceKind "sabre" = Just Sabre
-readDeviceKind _ = Nothing
View
102 Roguestar/Lib/Roguestar.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE Rank2Types, OverloadedStrings #-}
module Roguestar.Lib.Roguestar
(Game,
@@ -13,6 +13,9 @@ module Roguestar.Lib.Roguestar
perceive,
behave,
Roguestar.Lib.Roguestar.facingBehavior,
+ Roguestar.Lib.Roguestar.hasSnapshot,
+ popSnapshot,
+ getMessages,
Behavior(..))
where
@@ -29,14 +32,18 @@ import Roguestar.Lib.Perception
import Roguestar.Lib.TerrainData
import Roguestar.Lib.Facing
import Roguestar.Lib.Behavior as Behavior
+import Roguestar.Lib.Turns
+import Data.Text as T
data Game = Game {
- game_db :: TVar DB_BaseType }
+ game_db :: TVar DB_BaseType,
+ game_message_text :: TVar [T.Text] }
newGame :: IO Game
newGame =
do db <- newTVarIO initial_db
- return $ Game db
+ empty_messages <- newTVarIO []
+ return $ Game db empty_messages
peek :: Game -> DB a -> IO (Either DBError a)
peek g f =
@@ -60,26 +67,99 @@ getPlayerState :: Game -> IO (Either DBError PlayerState)
getPlayerState g = peek g playerState
rerollStartingSpecies :: Game -> IO (Either DBError Species)
-rerollStartingSpecies g = poke g $
- do species <- pickM all_species
- generateInitialPlayerCreature species
- return species
+rerollStartingSpecies g =
+ do atomically $
+ do writeTVar (game_db g) initial_db
+ writeTVar (game_message_text g) []
+ poke g $
+ do species <- pickM all_species
+ generateInitialPlayerCreature species
+ return species
beginGame :: Game -> IO (Either DBError ())
beginGame g = poke g $ BeginGame.beginGame
perceive :: Game -> (forall m. DBReadable m => DBPerception m a) -> IO (Either DBError a)
perceive g f = peek g $
- do player_creature <- maybe (fail "No player creature selected yet.") return =<< getPlayerCreature
+ do player_creature <- getPlayerCreature
runPerception player_creature f
+-- TODO: this should be moved into the Perception monad
facingBehavior :: Game -> Facing -> IO (Either DBError Behavior)
facingBehavior g facing = peek g $
- do player_creature <- maybe (fail "No player creature selected yet.") return =<< getPlayerCreature
+ do player_creature <- getPlayerCreature
Behavior.facingBehavior player_creature facing
behave :: Game -> Behavior -> IO (Either DBError ())
behave g b = poke g $
- do player_creature <- maybe (fail "No player creature selected yet.") return =<< getPlayerCreature
- dbBehave b player_creature
+ do player_creature <- getPlayerCreature
+ dbPerformPlayerTurn b player_creature
+hasSnapshot :: Game -> IO (Either DBError Bool)
+hasSnapshot g = peek g DB.hasSnapshot
+
+perceiveSnapshot :: Game -> (forall m. DBReadable m => DBPerception m a) -> IO (Either DBError a)
+perceiveSnapshot g f = peek g $ peepOldestSnapshot $
+ do player_creature <- getPlayerCreature
+ runPerception player_creature f
+
+getSnapshotPlayerState :: Game -> IO (Either DBError PlayerState)
+getSnapshotPlayerState g = peek g $ DB.peepOldestSnapshot $ playerState
+
+popSnapshot :: Game -> IO (Either DBError ())
+popSnapshot g =
+ do msgs <- poke g $
+ do msgs <- DB.peepOldestSnapshot unpackMessages
+ DB.popOldestSnapshot
+ return msgs
+ case msgs of
+ Right ts -> liftM Right $ mapM_ (putMessage g) ts
+ Left e -> return $ Left e
+
+max_messages :: Int
+max_messages = 20
+
+putMessage :: Game -> T.Text -> IO ()
+putMessage g t = (putStrLn $ T.unpack t) >> (atomically $
+ do ts <- readTVar $ game_message_text g
+ writeTVar (game_message_text g) $ Prelude.take max_messages $ t:ts)
+
+getMessages :: Game -> IO [T.Text]
+getMessages g = readTVarIO (game_message_text g)
+
+unpackMessages :: (DBReadable db) => db [T.Text]
+unpackMessages =
+ do player_state <- playerState
+ case player_state of
+ SpeciesSelectionState {} -> return []
+ PlayerCreatureTurn {} -> return []
+ SnapshotEvent evt ->
+ do player_creature <- getPlayerCreature
+ runPerception player_creature $ unpackMessages_ evt
+ GameOver -> return ["You have been destroyed."]
+
+unpackMessages_ :: (DBReadable m) => SnapshotEvent -> DBPerception m [T.Text]
+unpackMessages_ AttackEvent { attack_event_source_creature = c } =
+ do player_creature <- whoAmI
+ return $ case () of
+ () | c == player_creature -> ["The recreant zaps you!"]
+ () | otherwise -> ["You zap the recreant!"]
+unpackMessages_ MissEvent { miss_event_creature = c } =
+ do player_creature <- whoAmI
+ return $ case () of
+ () | c == player_creature -> ["You try to zap the recreant, but miss."]
+ () | otherwise -> ["A recreant tries to zap you, but misses."]
+unpackMessages_ KilledEvent { killed_event_creature = c } =
+ do player_creature <- whoAmI
+ return $ case () of
+ () | c == player_creature -> ["You have been destroyed!"]
+ () | otherwise -> ["You destroy the recreant!"]
+unpackMessages_ WeaponOverheatsEvent {} = return ["Your weapon overheats."]
+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_ ClimbEvent {} = return ["You wonder through a network of tunnels."]
+unpackMessages_ HealEvent {} = return ["You heal."]
+unpackMessages_ ExpendToolEvent {} = return ["That material sphere has been used up."]
+unpackMessages_ BumpEvent {} = return ["You feel more powerful!"]
View
52 Roguestar/Lib/Species.hs
@@ -6,7 +6,6 @@ module Roguestar.Lib.Species
import Data.Char
import Roguestar.Lib.CreatureData
-import Roguestar.Lib.CharacterData
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.CreatureAttribute
import Data.Monoid
@@ -32,100 +31,73 @@ speciesInfo Anachronid = SpeciesData (Speed & Mindfulness & SpotSkill) [
gender 0.0,
aptitudeBlock 10 25 [Speed,Mindfulness],
attributeStatic 15 SpotSkill,
- surpriseAptitudes,
- attributeStatic 1 $ FavoredClass Barbarian,
- attributeStatic 1 $ FavoredClass Pirate]
+ surpriseAptitudes]
speciesInfo Androsynth = SpeciesData (Strength & Intellect) [
- aptitudeBlock 12 17 [Strength,Intellect],
- attributeStatic 1 $ FavoredClass Engineer]
+ aptitudeBlock 12 17 [Strength,Intellect]]
speciesInfo Ascendant = SpeciesData (Strength & Mindfulness) [
gender 0.5,
aptitudeBlock 5 15 [Strength,Mindfulness],
surpriseAptitudes,
- attributeStatic 10 JumpSkill,
- attributeStatic 1 $ FavoredClass Shepherd,
- attributeStatic 1 $ FavoredClass ForceAdept]
+ attributeStatic 10 JumpSkill]
speciesInfo Caduceator = SpeciesData (Strength & Charisma) [
gender 0.5,
aptitudeBlock 5 15 [Strength,Charisma],
- surpriseAptitudes,
- attributeStatic 1 $ FavoredClass Consular]
+ surpriseAptitudes]
speciesInfo DustVortex = SpeciesData (Speed & Mindfulness) [
aptitudeBlock 3 5 [Speed,Mindfulness],
- attributeStatic 10 JumpSkill,
- attributeStatic 1 $ FavoredClass Barbarian]
+ attributeStatic 10 JumpSkill]
speciesInfo Encephalon = SpeciesData (Constitution & Intellect) [
gender 0.5,
- aptitudeBlock 3 20 [Constitution,Intellect],
- attributeStatic 1 $ FavoredClass Engineer]
+ aptitudeBlock 3 20 [Constitution,Intellect]]
speciesInfo Hellion = SpeciesData (Strength & Perception) [
gender 0.5,
aptitudeBlock 5 15 [Strength,Perception],
surpriseAptitudes,
- attributeStatic 5 $ HideSkill,
- attributeStatic 1 $ FavoredClass Scout,
- attributeStatic 1 $ FavoredClass Marine,
- attributeStatic 1 $ FavoredClass Thief,
- attributeStatic 1 $ FavoredClass Pirate]
+ attributeStatic 5 $ HideSkill]
speciesInfo Goliath = SpeciesData (Constitution & Perception) [
gender 0.5,
aptitudeBlock 3 20 [Constitution,Perception],
surpriseAptitudes,
attributeStatic 4 $ DamageReductionTrait Melee,
attributeStatic 4 $ DamageReductionTrait Ranged,
- attributeStatic 4 $ DamageReductionTrait Unarmed,
- attributeStatic 1 $ FavoredClass Barbarian,
- attributeStatic 1 $ FavoredClass Warrior,
- attributeStatic 1 $ FavoredClass Scout]
+ attributeStatic 4 $ DamageReductionTrait Unarmed]
speciesInfo Kraken = SpeciesData (Constitution & Charisma) [
gender 0.5,
aptitudeBlock 3 20 [Constitution,Charisma],
attributeStatic 1 $ TerrainAffinity Water,
- surpriseAptitudes,
- attributeStatic 1 $ FavoredClass Consular]
+ surpriseAptitudes]
speciesInfo Myrmidon = SpeciesData (Speed & Intellect) [
gender 0.0,
aptitudeBlock 5 15 [Speed,Intellect],
surpriseAptitudes,
- attributeStatic 1 $ FavoredClass Barbarian,
- attributeStatic 1 $ FavoredClass Engineer,
- attributeStatic 1 $ FavoredClass Warrior,
attributeStatic 5 $ AttackSkill Melee,
attributeStatic 5 $ DefenseSkill Melee]
speciesInfo Perennial = SpeciesData (Constitution & Mindfulness) [
aptitudeBlock 1 25 [Constitution, Mindfulness],
attributeStatic 1 $ TerrainAffinity Forest,
attributeStatic 1 $ TerrainAffinity DeepForest,
- surpriseAptitudes,
- attributeStatic 1 $ FavoredClass Barbarian,
- attributeStatic 1 $ FavoredClass Engineer,
- attributeStatic 1 $ FavoredClass Consular,
- attributeStatic 1 $ FavoredClass Shepherd]
+ surpriseAptitudes]
speciesInfo Recreant = SpeciesData (Speed & Perception) [
aptitudeBlock 2 5 [Speed,Perception],
surpriseAptitudes, surpriseAptitudes,
attributeStatic 5 $ AttackSkill Ranged,
- attributeStatic 5 $ DamageSkill Ranged,
- attributeStatic 1 $ FavoredClass Marine,
- attributeStatic 1 $ FavoredClass Scout]
+ attributeStatic 5 $ DamageSkill Ranged]
speciesInfo Reptilian = SpeciesData (Speed & Charisma) [
gender 0.5,
aptitudeBlock 5 15 [Speed,Charisma],
surpriseAptitudes,
attributeStatic 5 $ AttackSkill Unarmed,
- attributeStatic 5 $ DefenseSkill Unarmed,
- attributeStatic 1 $ FavoredClass Warrior,
- attributeStatic 1 $ FavoredClass Consular]
+ attributeStatic 5 $ DefenseSkill Unarmed]
View
2 Roguestar/Lib/SpeciesData.hs
@@ -20,5 +20,5 @@ data Species =
deriving (Eq,Ord,Bounded,Enum,Read,Show)
all_species :: [Species]
-all_species = [minBound..maxBound]
+all_species = [Recreant] -- [minBound..maxBound]
View
14 Roguestar/Lib/Substances.hs
@@ -14,7 +14,6 @@ module Roguestar.Lib.Substances
isChromalite,
substances,
prettySubstance,
- printSubstances,
gasValue,
chromaliteAlignment,
chromalitePotency)
@@ -24,7 +23,7 @@ import Roguestar.Lib.Alignment
import Data.List
import Data.Ord
import Data.Maybe
-import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
data Substance =
GasSubstance Gas
@@ -37,13 +36,10 @@ substances = map GasSubstance [minBound..maxBound] ++
map MaterialSubstance [minBound..maxBound] ++
map ChromaliteSubstance [minBound..maxBound]
-prettySubstance :: Substance -> B.ByteString
-prettySubstance (GasSubstance x) = B.pack $ show x
-prettySubstance (MaterialSubstance x) = B.pack $ show x
-prettySubstance (ChromaliteSubstance x) = B.pack $ show x
-
-printSubstances :: IO ()
-printSubstances = B.putStrLn $ B.unlines $ map (\(x,y) -> prettySubstance y `B.append` ": " `B.append` B.pack (show x)) $ sortBy (comparing fst) $ map (\x -> (substanceValue x,x)) substances
+prettySubstance :: Substance -> T.Text
+prettySubstance (GasSubstance x) = T.pack $ show x
+prettySubstance (MaterialSubstance x) = T.pack $ show x
+prettySubstance (ChromaliteSubstance x) = T.pack $ show x
data Solid = MaterialSolid Material
| ChromaliteSolid Chromalite
View
12 Roguestar/Lib/ToolData.hs
@@ -27,13 +27,13 @@ module Roguestar.Lib.ToolData
where
import Roguestar.Lib.Substances
-import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
data Tool = DeviceTool DeviceFunction Device
| Sphere Substance
deriving (Read,Show,Eq)
-toolName :: Tool -> B.ByteString
+toolName :: Tool -> T.Text
toolName (DeviceTool _ d) = deviceName d
toolName (Sphere s) = prettySubstance s
@@ -66,7 +66,7 @@ kindToFunction Sabre = (Sword,4)
-- | Any kind of device that is constructed from a power cell, materal, and gas medium,
-- using the various device rules to determine it's power.
data Device = Device {
- device_name :: B.ByteString,
+ device_name :: T.Text,
device_chromalite :: Chromalite,
device_material :: Material,
device_gas :: Gas,
@@ -97,12 +97,12 @@ instance DeviceType Device where
instance DeviceType PseudoDevice where
toPseudoDevice = id
-device :: B.ByteString -> DeviceKind -> Chromalite -> Material -> Gas -> Tool
+device :: T.Text -> DeviceKind -> Chromalite -> Material -> Gas -> Tool
device s dk c m g = DeviceTool func (Device s c m g size)
where (func,size) = kindToFunction dk
improvised :: DeviceKind -> Chromalite -> Material -> Gas -> Tool
-improvised dk c m g = device ("improvised_" `B.append` B.pack (show dk)) dk c m g
+improvised dk c m g = device ("improvised_" `T.append` T.pack (show dk)) dk c m g
phase_pistol :: Tool
phase_pistol = device "phase_pistol" Pistol Caerulite Zinc Flourine
@@ -119,7 +119,7 @@ kinetic_fleuret = device "kinetic_fleuret" Fleuret Ionidium Aluminum Nitrogen
kinetic_sabre :: Tool
kinetic_sabre = device "kinetic_sabre" Sabre Ionidium Aluminum Nitrogen
-deviceName :: Device -> B.ByteString
+deviceName :: Device -> T.Text
deviceName = device_name
deviceDurability :: Device -> Integer
View
170 Roguestar/Server/Main.hs
@@ -5,6 +5,7 @@ import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import qualified Text.XHtmlCombinators.Escape as XH
import qualified Text.XmlHtml as X
+import Text.Templating.Heist
import Control.Exception (SomeException)
import qualified Control.Monad.CatchIO as CatchIO
import Control.Monad.Trans
@@ -35,6 +36,8 @@ import Roguestar.Lib.Substances as Substances
import Roguestar.Lib.TerrainData as TerrainData
import Roguestar.Lib.CreatureData
import Roguestar.Lib.Facing
+import Roguestar.Lib.DBData (Reference,ToolRef,toUID)
+import qualified Data.UUID.V4 as V4
data App = App {
_heist :: Snaplet (Heist App),
@@ -45,12 +48,13 @@ makeLenses [''App]
instance HasHeist App where heistLens = subSnaplet heist
appInit :: SnapletInit App App
-appInit = makeSnaplet "taskflask" "Task Flask" Nothing $
+appInit = makeSnaplet "roguestar-server-snaplet" "Roguestar Server" Nothing $
do hs <- nestSnaplet "heist" heist $ heistInit "templates"
addRoutes [("/play", play),
("/static", static),
("/hidden", handle404),
("/fail", handle500 (do error "my brain exploded")),
+ ("/feedback", feedback),
("", heistServe)]
game <- liftIO newGame
wrapHandlers (<|> handle404)
@@ -79,18 +83,40 @@ handle404 =
static :: Handler App App ()
static = serveDirectory "./static/"
+feedback :: Handler App App ()
+feedback = method POST $
+ do feedback <- liftM (fromMaybe $ error "No feedback.") $ getPostParam "feedback"
+ liftIO $
+ do uuid <- V4.nextRandom
+ BS.writeFile ("./feedback/" ++ show uuid) feedback
+ redirect "/feedback-thanks/"
+
play :: Handler App App ()
play =
+ do resolveSnapshots
+ g <- getGame
+ player_state <- oops $ liftIO $ getPlayerState g
+ route [("",method GET $ displayCurrentState player_state),
+ ("maptext",method GET $ createMap >>= writeText),
+ ("reroll",method POST $ reroll player_state),
+ ("accept",method POST $ accept player_state),
+ ("move",method POST $ move),
+ ("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 =
do g <- getGame
- player_state <- liftIO $ getPlayerState g
- case player_state of
- Right something ->
- routeRoguestar something
- [("",method GET . displayCurrentState),
- ("maptext",method GET . const (createMap >>= writeText)),
- ("reroll",method POST . reroll),
- ("accept",method POST . accept),
- ("move",method POST . move)]
+ b <- oops $ liftIO $ hasSnapshot g
+ case b of
+ True ->
+ do oops $ liftIO $ popSnapshot g
+ resolveSnapshots
+ False ->
+ do return ()
routeRoguestar :: PlayerState -> [(BS.ByteString,PlayerState -> Handler App App ())] -> Handler App App ()
routeRoguestar ps xs = route $ map (\(bs,f) -> (bs,f ps)) xs
@@ -104,11 +130,55 @@ displayCurrentState (SpeciesSelectionState (Just creature)) =
displayCurrentState (PlayerCreatureTurn creature_ref) =
do map_text <- createMap
player_stats <- createStatsBlock
- renderWithSplices "/hidden/play/normal-play"
+ messages <- liftIO . getMessages =<< getGame
+ renderWithSplices "/hidden/play/normal"
[("map",return $ [X.Element "pre" [] [X.TextNode map_text]]),
- ("statsblock",return $ [X.Element "pre" [] [X.TextNode player_stats]])]
+ ("statsblock",return $ [X.Element "pre" [] [X.TextNode player_stats]]),
+ ("messages",return $ map (\x -> X.Element "p" [] [X.TextNode x]) messages)]
+displayCurrentState GameOver =
+ do render "/hidden/play/game-over"
displayCurrentState _ = pass
+data Inventory = Inventory {
+ inventory_wielded :: Maybe VisibleObject,
+ inventory_carried :: [VisibleObject],
+ inventory_ground :: [VisibleObject] }
+
+collectInventory :: Game -> Handler App App (Either DBError Inventory)
+collectInventory g = liftIO $ perceive g $
+ do visible_objects <- liftM stackVisibleObjects $ visibleObjects (const $ return True)
+ (_,my_position) <- whereAmI
+ let vobs_at_my_position = Map.lookup my_position visible_objects
+ my_inventory <- myInventory
+ return $ Inventory {
+ inventory_wielded =
+ do me <- List.find isVisibleCreature $ fromMaybe [] vobs_at_my_position
+ visible_creature_wielding me,
+ inventory_ground = filter isVisibleTool $ fromMaybe [] vobs_at_my_position,
+ inventory_carried = my_inventory }
+
+displayInventory :: Handler App App ()
+displayInventory =
+ do g <- getGame
+ inventory_result <- collectInventory g
+ inventory <- case inventory_result of
+ Right inventory -> return inventory
+ renderWithSplices "/hidden/play/inventory"
+ [("wielded", return $ inventoryList [("Unwield","carried","/play/unwield"),("Drop","ground","/play/drop")] $ maybeToList $ inventory_wielded inventory),
+ ("carried", return $ inventoryList [("Wield","wielded","/play/wield"),("Drop","ground","/play/drop")] $ inventory_carried inventory),
+ ("ground", return $ inventoryList [("Wield","wielded","/play/wield"),("Pickup","carried","/play/pickup")] $ inventory_ground inventory)]
+
+inventoryList :: [(T.Text,T.Text,T.Text)] -> [VisibleObject] -> Template
+inventoryList inventory_actions = map inventoryItem
+ where inventoryItem (VisibleTool { visible_tool_ref = tool_ref, visible_tool = tool }) =