Skip to content
This repository
Browse code

Getting to be a fairly acceptable web game.

  • Loading branch information...
commit 9195ff6f27701abdf1395892b4f6f21c05ce8e7d 1 parent 57bc446
Christopher Lane Hinson authored July 19, 2012

Showing 49 changed files with 1,575 additions and 1,301 deletions. Show diff stats Hide diff stats

  1. 1  Roguestar/Lib/BeginGame.hs
  2. 1  Roguestar/Lib/BuildingData.hs
  3. 91  Roguestar/Lib/Character.hs
  4. 2  Roguestar/Lib/CharacterAdvancement.hs
  5. 25  Roguestar/Lib/CharacterData.hs
  6. 17  Roguestar/Lib/CreatureData.hs
  7. 30  Roguestar/Lib/DB.hs
  8. 88  Roguestar/Lib/GridRayCaster.hs
  9. 54  Roguestar/Lib/HierarchicalDatabase.hs
  10. 45  Roguestar/Lib/Perception.hs
  11. 13  Roguestar/Lib/PersistantData.hs
  12. 2  Roguestar/Lib/PlayerState.hs
  13. 785  Roguestar/Lib/Protocol.hs
  14. 102  Roguestar/Lib/Roguestar.hs
  15. 52  Roguestar/Lib/Species.hs
  16. 2  Roguestar/Lib/SpeciesData.hs
  17. 14  Roguestar/Lib/Substances.hs
  18. 12  Roguestar/Lib/ToolData.hs
  19. 170  Roguestar/Server/Main.hs
  20. 325  devnotes/MonsterColors.html
  21. 325  devnotes/TerrainColors.html
  22. 1  feedback/1b6f660f-70e0-4781-a10b-1033c2c23323
  23. 13  roguestar.cabal
  24. 2  snaplets/heist/templates/404.tpl
  25. 68  snaplets/heist/templates/contribute.tpl
  26. 11  snaplets/heist/templates/feedback-thanks.tpl
  27. 16  snaplets/heist/templates/feedback.tpl
  28. 37  snaplets/heist/templates/help.tpl
  29. 18  snaplets/heist/templates/hidden/context.tpl
  30. 11  snaplets/heist/templates/hidden/contribute/artwork.tpl
  31. 1  snaplets/heist/templates/hidden/contribute/haskell.tpl
  32. 5  snaplets/heist/templates/hidden/contribute/other.tpl
  33. 3  snaplets/heist/templates/hidden/contribute/webtalent.tpl
  34. 9  snaplets/heist/templates/hidden/help/keys.tpl
  35. 3  snaplets/heist/templates/hidden/help/wth.tpl
  36. 1  snaplets/heist/templates/hidden/links/contact-me.tpl
  37. 2  snaplets/heist/templates/hidden/links/github.tpl
  38. 13  snaplets/heist/templates/hidden/play/character-creation.tpl
  39. 3  snaplets/heist/templates/hidden/play/context.tpl
  40. 17  snaplets/heist/templates/hidden/play/empty-game.tpl
  41. 10  snaplets/heist/templates/hidden/play/game-over.tpl
  42. 18  snaplets/heist/templates/hidden/play/inventory.tpl
  43. 46  snaplets/heist/templates/hidden/play/{normal-play.tpl → normal.tpl}
  44. 3  snaplets/heist/templates/hidden/ui/faq.tpl
  45. 4  snaplets/heist/templates/hidden/ui/faqbox.tpl
  46. 5  snaplets/heist/templates/index.tpl
  47. 4  static/encyclopedia/species/recreant.txt
  48. 321  static/roguebasic.css
  49. 75  static/roguestar.css
1  Roguestar/Lib/BeginGame.hs
@@ -6,7 +6,6 @@ module Roguestar.Lib.BeginGame
6 6
 import Roguestar.Lib.Plane
7 7
 import Roguestar.Lib.CreatureData
8 8
 import Roguestar.Lib.Character
9  
-import Roguestar.Lib.CharacterData
10 9
 import Roguestar.Lib.BuildingData
11 10
 import Roguestar.Lib.DB
12 11
 import Roguestar.Lib.Facing
1  Roguestar/Lib/BuildingData.hs
@@ -13,7 +13,6 @@ module Roguestar.Lib.BuildingData
13 13
     where
14 14
 
15 15
 import Roguestar.Lib.PowerUpData
16  
-import Roguestar.Lib.CharacterData
17 16
 import Roguestar.Lib.PersistantData
18 17
 
19 18
 basic_stargate :: BuildingPrototype
91  Roguestar/Lib/Character.hs
... ...
@@ -1,98 +1,18 @@
1 1
 
2 2
 module Roguestar.Lib.Character
3  
-    (getEligableCharacterClasses,
4  
-     getEligableBaseCharacterClasses,
5  
-     applyCharacterClass)
  3
+    (applyCharacterClass)
6 4
     where
7 5
 
8 6
 import Roguestar.Lib.Alignment
9  
-import Roguestar.Lib.CharacterData
10 7
 import Roguestar.Lib.CreatureAttribute
11 8
 import Roguestar.Lib.CreatureData
12 9
 import Roguestar.Lib.TerrainData
13  
-
14  
-type Prerequisite = Creature -> Bool
15  
-
16  
-data CharacterClassData = CharacterClassData {
17  
-    character_class_prerequisite :: Prerequisite,
18  
-    character_class_attributes :: CreatureAttribute }
19  
-
20  
-getEligableCharacterClassesComposable :: [CharacterClass] -> Creature -> [CharacterClass]
21  
-getEligableCharacterClassesComposable allowed_classes creature =
22  
-    filter (\x -> character_class_prerequisite (classInfo x) creature || isFavoredClass x creature) allowed_classes
23  
-
24  
-getEligableCharacterClasses :: Creature -> [CharacterClass]
25  
-getEligableCharacterClasses = getEligableCharacterClassesComposable all_character_classes
26  
-
27  
-getEligableBaseCharacterClasses :: Creature -> [CharacterClass]
28  
-getEligableBaseCharacterClasses = getEligableCharacterClassesComposable base_character_classes
29  
-
30  
-prerequisites :: [Prerequisite] -> Prerequisite
31  
-prerequisites prereqs creature = all ($ creature) prereqs
32  
-
33  
-mustHave :: (CreatureScore a) => a -> Integer -> Prerequisite
34  
-mustHave score min_score creature = (rawScore score creature) >= min_score
35  
-
36  
--- |
37  
--- Constructor function for CharacterClassData objects.
38  
---
39  
--- The first parameter should be the prerequisite (or more than one prerequisite using the 'prerequisites'
40  
--- function).  The prerequisite(s) restrict what 'Creatures' can advance in the 'CharacterClass'.
41  
---
42  
--- The second parameter is the list of 'CreatureAttribute's that a Creature gains when it levels in the 
43  
--- 'CharacterClass'.
44  
---
45  
-characterClass :: Prerequisite -> CreatureAttribute -> CharacterClassData
46  
-characterClass prereqs attribs = CharacterClassData prereqs attribs
  10
+import Roguestar.Lib.PersistantData
47 11
 
48 12
 applyCharacterClass :: CharacterClass -> Creature -> Creature
49  
-applyCharacterClass character_class creature = applyToCreature (character_class & character_class_attributes (classInfo character_class)) creature
50  
-
51  
-classInfo :: CharacterClass -> CharacterClassData
52  
-
53  
--------------------------------------------------------------------------------
54  
---
55  
---  Base Classes
56  
---
57  
---  These are base classes: these classes have very low prerequisites,
58  
---  with the intention that characters can choose them at the beginning
59  
---  of a game.  They also contain extra information about the character's
60  
---  starting equipment and situation.
61  
---
62  
--------------------------------------------------------------------------------
63  
-
64  
-classInfo Barbarian = characterClass (prerequisites [mustHave Strength 15,mustHave Constitution 15]) $
65  
-		     DamageReductionTrait Melee & DamageReductionTrait Ranged & DamageReductionTrait Unarmed & ToughnessTrait & Speed & Constitution & Strength & Indifferent
66  
-
67  
-classInfo Consular = characterClass (mustHave Charisma 20) $
68  
-		     Charisma & Diplomatic
69  
-
70  
-classInfo Engineer = characterClass (mustHave Intellect 20) $
71  
-		     Intellect & Strategic
72  
-
73  
-classInfo ForceAdept = characterClass (prerequisites [mustHave Intellect 15, mustHave Perception 15, mustHave Charisma 15, mustHave Mindfulness 15]) $
74  
-		     DefenseSkill Ranged & DefenseSkill Melee & AttackSkill Melee & Speed & Perception & Mindfulness & Indifferent
75  
-
76  
-classInfo Marine = characterClass (prerequisites [mustHave Perception 15,mustHave Constitution 15]) $
77  
-		     AttackSkill Ranged & DefenseSkill Ranged & Constitution & Speed & Perception & Mindfulness & Tactical
78  
-		   
79  
-classInfo Ninja = characterClass (prerequisites [mustHave Speed 15,mustHave Perception 15]) $
80  
-		     HideSkill & DefenseSkill Melee & DefenseSkill Ranged & Speed & Indifferent
81  
-
82  
-classInfo Pirate = characterClass (prerequisites [mustHave Strength 10,mustHave Perception 10, mustHave Speed 10, mustHave Charisma 10]) $
83  
-		     AttackSkill Ranged & ToughnessTrait & Strength & Speed
84  
-
85  
-classInfo Scout = characterClass (prerequisites [mustHave Perception 20]) $
86  
-		     SpotSkill & Speed & Perception & Tactical
87  
-
88  
-classInfo Shepherd = characterClass (prerequisites [mustHave Charisma 15,mustHave Mindfulness 15]) $
89  
-		     SpotSkill & TerrainAffinity Grass & Perception & Mindfulness & Indifferent
90  
-
91  
-classInfo Thief = characterClass (mustHave Perception 20) $
92  
-		     HideSkill & Speed & Charisma & Perception & Tactical
  13
+applyCharacterClass character_class creature = applyToCreature (character_class & classInfo character_class) creature
93 14
 
94  
-classInfo Warrior = characterClass (prerequisites [mustHave Strength 15,mustHave Speed 15]) $
95  
-		    AttackSkill Melee & DefenseSkill Melee & Constitution & Strength & Speed & Mindfulness & Tactical
  15
+classInfo :: CharacterClass -> CreatureAttribute
96 16
 
97 17
 -------------------------------------------------------------------------------
98 18
 --
@@ -102,6 +22,5 @@ classInfo Warrior = characterClass (prerequisites [mustHave Strength 15,mustHave
102 22
 --
103 23
 -------------------------------------------------------------------------------
104 24
 
105  
-classInfo StarChild = characterClass (prerequisites []) $
106  
-                      Intellect & Indifferent
  25
+classInfo StarChild = Mindfulness & Intellect & Perception
107 26
 
2  Roguestar/Lib/CharacterAdvancement.hs
@@ -9,8 +9,8 @@ module Roguestar.Lib.CharacterAdvancement
9 9
 
10 10
 import qualified Data.Map as Map
11 11
 import Roguestar.Lib.CreatureData
12  
-import Roguestar.Lib.CharacterData
13 12
 import Roguestar.Lib.PowerUpData
  13
+import Roguestar.Lib.PersistantData
14 14
 
15 15
 data CharacterBumpResult =
16 16
     CharacterAwarded  { character_points_awarded :: Integer,
25  Roguestar/Lib/CharacterData.hs
... ...
@@ -1,25 +0,0 @@
1  
-
2  
-module Roguestar.Lib.CharacterData
3  
-    (CharacterClass(..),
4  
-     all_character_classes,
5  
-     base_character_classes)
6  
-    where
7  
-
8  
-import Roguestar.Lib.PersistantData
9  
-
10  
-all_character_classes :: [CharacterClass]
11  
-all_character_classes = [minBound..maxBound]
12  
-
13  
-base_character_classes :: [CharacterClass]
14  
-base_character_classes = [Barbarian,
15  
-                          Consular,
16  
-                          Engineer,
17  
-                          ForceAdept,
18  
-                          Marine,
19  
-                          Ninja,
20  
-                          Pirate,
21  
-                          Scout,
22  
-                          Shepherd,
23  
-                          Thief,
24  
-                          Warrior]
25  
-
17  Roguestar/Lib/CreatureData.hs
@@ -7,16 +7,14 @@ module Roguestar.Lib.CreatureData
7 7
      CreatureAbility(..),
8 8
      CreatureEndo(..),
9 9
      CreatureScore(..),
10  
-     FavoredClass(..),
11 10
      CreatureHealth(..),
12 11
      creatureGender,
13 12
      creatureHealth,
14 13
      creatureAbilityScore,
15  
-     isFavoredClass,
16 14
      empty_creature)
17 15
     where
18 16
 
19  
-import Roguestar.Lib.CharacterData
  17
+import Roguestar.Lib.PersistantData
20 18
 import Roguestar.Lib.Alignment
21 19
 import Data.Ratio
22 20
 import Data.Maybe
@@ -31,7 +29,6 @@ data Creature = Creature { creature_aptitude :: Map.Map CreatureAptitude Integer
31 29
                            creature_ability :: Map.Map CreatureAbility Integer,
32 30
                            creature_ethical :: Map.Map EthicalAlignment Integer,
33 31
                            creature_levels :: Map.Map CharacterClass Integer,
34  
-                           creature_favored_classes :: Set.Set CharacterClass,
35 32
                            creature_gender :: CreatureGender,
36 33
                            creature_species :: Species,
37 34
                            creature_random_id :: Integer, -- random number attached to the creature, not unique
@@ -48,7 +45,6 @@ empty_creature = Creature {
48 45
     creature_ability = Map.empty,
49 46
     creature_ethical = Map.empty,
50 47
     creature_levels = Map.empty,
51  
-    creature_favored_classes = Set.empty,
52 48
     creature_gender = Neuter,
53 49
     creature_species = error "empty_creature: undefined creature_species",
54 50
     creature_random_id = error "empty_creature: undefined creature_random_id",
@@ -140,11 +136,6 @@ instance CreatureEndo CharacterClass where
140 136
 instance CreatureScore CharacterClass where
141 137
     rawScore character_class c = fromMaybe 0 $ Map.lookup character_class $ creature_levels c
142 138
 
143  
-newtype FavoredClass = FavoredClass CharacterClass
144  
-
145  
-instance CreatureEndo FavoredClass where
146  
-    applyToCreature (FavoredClass favored_class) c = c { creature_favored_classes = Set.insert favored_class $ creature_favored_classes c }
147  
-
148 139
 -- | Calculator to determine how many ranks a creature has in an ability.
149 140
 -- Number of aptitude points plus n times number of ability points
150 141
 figureAbility :: [CreatureAptitude] -> (CreatureAbility,Integer) -> Creature -> Integer
@@ -185,12 +176,6 @@ creatureGender :: Creature -> CreatureGender
185 176
 creatureGender = creature_gender
186 177
 
187 178
 -- |
188  
--- Answers true if the specified class is a favored class for this creature.
189  
---
190  
-isFavoredClass :: CharacterClass -> Creature -> Bool
191  
-isFavoredClass character_class creature = character_class `Set.member` (creature_favored_classes creature)
192  
-
193  
--- |
194 179
 -- Answers the health/injury/maximum health of this creature.
195 180
 creatureHealth :: Creature -> CreatureHealth
196 181
 creatureHealth c = result
30  Roguestar/Lib/DB.hs
@@ -45,9 +45,9 @@ module Roguestar.Lib.DB
45 45
      dbAdvanceTime,
46 46
      dbNextTurn,
47 47
      dbPushSnapshot,
48  
-     dbPeepOldestSnapshot,
49  
-     dbPopOldestSnapshot,
50  
-     dbHasSnapshot,
  48
+     peepOldestSnapshot,
  49
+     popOldestSnapshot,
  50
+     hasSnapshot,
51 51
      module Roguestar.Lib.DBData,
52 52
      module Roguestar.Lib.DBErrorFlag,
53 53
      module Roguestar.Lib.Random)
@@ -229,8 +229,8 @@ playerState = asks db_player_state
229 229
 setPlayerState :: PlayerState -> DB ()
230 230
 setPlayerState state = modify (\db -> db { db_player_state = state })
231 231
 
232  
-getPlayerCreature :: (DBReadable m) => m (Maybe CreatureRef)
233  
-getPlayerCreature = asks db_player_creature
  232
+getPlayerCreature :: (DBReadable m) => m CreatureRef
  233
+getPlayerCreature = liftM (fromMaybe $ error "No player creature selected yet.") $ asks db_player_creature
234 234
 
235 235
 setPlayerCreature :: CreatureRef -> DB ()
236 236
 setPlayerCreature creature_ref = modify (\db -> db { db_player_creature = Just creature_ref })
@@ -515,20 +515,20 @@ dbPushSnapshot :: SnapshotEvent -> DB ()
515 515
 dbPushSnapshot e = modify $ \db -> db {
516 516
     db_prior_snapshot = Just $ db { db_player_state = SnapshotEvent e } }
517 517
 
518  
-dbPeepOldestSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
519  
-dbPeepOldestSnapshot actionM =
520  
-    do m_a <- dbPeepSnapshot $ dbPeepOldestSnapshot actionM
  518
+peepOldestSnapshot :: (DBReadable db) => (forall m. DBReadable m => m a) -> db a
  519
+peepOldestSnapshot actionM =
  520
+    do m_a <- dbPeepSnapshot $ peepOldestSnapshot actionM
521 521
        maybe actionM return m_a
522 522
 
523  
-dbPopOldestSnapshot :: DB ()
524  
-dbPopOldestSnapshot = modify popOldestSnapshot
  523
+popOldestSnapshot :: DB ()
  524
+popOldestSnapshot = modify popOldestSnapshot_
525 525
 
526  
-dbHasSnapshot :: (DBReadable db) => db Bool
527  
-dbHasSnapshot = liftM isJust $ dbPeepSnapshot (return ())
  526
+hasSnapshot :: (DBReadable db) => db Bool
  527
+hasSnapshot = liftM isJust $ dbPeepSnapshot (return ())
528 528
 
529  
-popOldestSnapshot :: DB_BaseType -> DB_BaseType
530  
-popOldestSnapshot db =
  529
+popOldestSnapshot_ :: DB_BaseType -> DB_BaseType
  530
+popOldestSnapshot_ db =
531 531
     case isJust $ db_prior_snapshot =<< db_prior_snapshot db of
532 532
         False -> db { db_prior_snapshot = Nothing }
533  
-        True  -> db { db_prior_snapshot = fmap popOldestSnapshot $ db_prior_snapshot db }
  533
+        True  -> db { db_prior_snapshot = fmap popOldestSnapshot_ $ db_prior_snapshot db }
534 534
 
88  Roguestar/Lib/GridRayCaster.hs
@@ -22,28 +22,28 @@ castRays src@(src_x,src_y) dests opacityFn =
22 22
     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)
23 23
     groupBy (\ a b -> compareDirection a b == EQ) $ -- order and group the all destinations that lie along the same ray
24 24
     sortBy (\ a b -> compareDirection a b) dests
25  
-	where lengthThenDistance a b = case (length a) `compare` (length b) of
26  
-									    EQ -> (head b) `compareDistance` (head a)
27  
-									    ordering -> ordering
28  
-	      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
29  
-	      compareDirection ((x1,y1),_) ((x2,y2),_) | (src_y - y1 == 0) && (src_y - y2 == 0) = signum (src_x-x1) `compare` signum (src_x-x2)
30  
-	      compareDirection ((_,y1),_) _ | (src_y - y1 == 0) = LT
31  
-	      compareDirection _ ((_,y2),_) | (src_y - y2 == 0) = GT
32  
-	      compareDirection ((x1,y1),_) ((x2,y2),_) = 
33  
-		  let slope1 = (src_x-x1)%(src_y-y1) 
34  
-		      slope2 = (src_x-x2)%(src_y-y2)
35  
-		      in case slope1 `compare` slope2 of
36  
-						      EQ -> signum (src_y-y1) `compare` signum (src_y-y2)
37  
-						      ordering -> ordering
38  
-	      castRays_ _ _ [] = []
39  
-	      -- in this case: if a more distant ray from a darker spot passes, then the nearer, brighter ray obviously passes (NOT cheating!)
40  
-	      castRays_ (Just old_brightness) m ((dest,brightness):rest) | brightness >= old_brightness = dest : (castRays_ (Just old_brightness) m rest)
41  
-	      -- 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!)
42  
-	      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)
43  
-	      -- if we don't have a basis to automatically include this spot, then actually cast a ray (expensive!)
44  
-	      castRays_ maybe_old_brightness m ((dest,brightness):rest) = if castRay src dest brightness opacityFn
45  
-									  then dest : (castRays_ (Just brightness) m rest)
46  
-									  else castRays_ maybe_old_brightness m rest
  25
+        where lengthThenDistance a b = case (length a) `compare` (length b) of
  26
+                                                                            EQ -> (head b) `compareDistance` (head a)
  27
+                                                                            ordering -> ordering
  28
+              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
  29
+              compareDirection ((x1,y1),_) ((x2,y2),_) | (src_y - y1 == 0) && (src_y - y2 == 0) = signum (src_x-x1) `compare` signum (src_x-x2)
  30
+              compareDirection ((_,y1),_) _ | (src_y - y1 == 0) = LT
  31
+              compareDirection _ ((_,y2),_) | (src_y - y2 == 0) = GT
  32
+              compareDirection ((x1,y1),_) ((x2,y2),_) = 
  33
+                  let slope1 = (src_x-x1)%(src_y-y1) 
  34
+                      slope2 = (src_x-x2)%(src_y-y2)
  35
+                      in case slope1 `compare` slope2 of
  36
+                                                      EQ -> signum (src_y-y1) `compare` signum (src_y-y2)
  37
+                                                      ordering -> ordering
  38
+              castRays_ _ _ [] = []
  39
+              -- in this case: if a more distant ray from a darker spot passes, then the nearer, brighter ray obviously passes (NOT cheating!)
  40
+              castRays_ (Just old_brightness) m ((dest,brightness):rest) | brightness >= old_brightness = dest : (castRays_ (Just old_brightness) m rest)
  41
+              -- 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!)
  42
+              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)
  43
+              -- if we don't have a basis to automatically include this spot, then actually cast a ray (expensive!)
  44
+              castRays_ maybe_old_brightness m ((dest,brightness):rest) = if castRay src dest brightness opacityFn
  45
+                                                                          then dest : (castRays_ (Just brightness) m rest)
  46
+                                                                          else castRays_ maybe_old_brightness m rest
47 47
 
48 48
 -- |
49 49
 -- Facade function to castRayForOpacity.
@@ -51,13 +51,13 @@ castRays src@(src_x,src_y) dests opacityFn =
51 51
 castRay :: (Integer,Integer) -> (Integer,Integer) -> Integer -> ((Integer,Integer) -> Integer) -> Bool
52 52
 castRay (ax,ay) (bx,by) brightness opacityFn =
53 53
     castRayForOpacity     (1/8)
54  
-			  (fromInteger ax,fromInteger ay)
55  
-			  (fromInteger bx,fromInteger by)
56  
-			  (fromInteger brightness)
57  
-			  (integerToFloatOpacityGrid opacityFn)
  54
+                          (fromInteger ax,fromInteger ay)
  55
+                          (fromInteger bx,fromInteger by)
  56
+                          (fromInteger brightness)
  57
+                          (integerToFloatOpacityGrid opacityFn)
58 58
 
59 59
 data Ray = Ray { ray_origin :: !(Float,Float),
60  
-		 ray_delta :: !(Float,Float) }
  60
+                 ray_delta :: !(Float,Float) }
61 61
 
62 62
 integerToFloatOpacityGrid :: ((Integer,Integer) -> Integer) -> ((Float,Float) -> Float)
63 63
 integerToFloatOpacityGrid fn (x,y) =
@@ -87,13 +87,13 @@ integerToFloatOpacityGrid fn (x,y) =
87 87
 castRayForOpacity :: Float -> (Float,Float) -> (Float,Float) -> Float -> ((Float,Float)->Float) -> Bool
88 88
 castRayForOpacity fineness a@(ax,ay) b@(bx,by) brightness rawOpacityFn =
89 89
     let ray = setRayLength fineness $ rayFromTo a b
90  
-	opacityFn = \ x -> (1 - rawOpacityFn x / 100) ** fineness
91  
-	lengthSquared (x1,y1) (x2,y2) = (x1-x2)^2 + (y1-y2)^2
92  
-	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))]
93  
-	in all (> 1) $
94  
-	   scanl (\ bright pt -> bright * opacityFn pt) brightness $
95  
-	   takeWhile ( \ pt -> lengthSquared a pt < goal_length) $
96  
-	   rayToPoints ray
  90
+        opacityFn = \ x -> (1 - rawOpacityFn x / 100) ** fineness
  91
+        lengthSquared (x1,y1) (x2,y2) = (x1-x2)^2 + (y1-y2)^2
  92
+        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))]
  93
+        in all (> 1) $
  94
+           scanl (\ bright pt -> bright * opacityFn pt) brightness $
  95
+           takeWhile ( \ pt -> lengthSquared a pt < goal_length) $
  96
+           rayToPoints ray
97 97
 
98 98
 -- |
99 99
 -- 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)
107 107
 setRayLength :: Float -> Ray -> Ray
108 108
 setRayLength new_distance ray@(Ray { ray_delta=(dx,dy) }) = 
109 109
     let old_distance = sqrt $ (dx^2 + dy^2)
110  
-	scalar = new_distance/old_distance
111  
-	in ray { ray_delta=(scalar*dx,scalar*dy) }
  110
+        scalar = new_distance/old_distance
  111
+        in ray { ray_delta=(scalar*dx,scalar*dy) }
112 112
 
113 113
 -- |
114 114
 -- Advances a ray by its ray_delta.
@@ -132,18 +132,18 @@ gridRayCasterTests = [easyRayTest,hardRayTest,tooHardRayTest,stressLazyRayTest]
132 132
 
133 133
 easyRayTest :: TestCase
134 134
 easyRayTest = (if castRay (4,5) (-3,-1) 100 sampleDensityFunction
135  
-	       then return (Passed "easyRayTest")
136  
-	       else return (Failed "easyRayTest"))
  135
+               then return (Passed "easyRayTest")
  136
+               else return (Failed "easyRayTest"))
137 137
 
138 138
 hardRayTest :: TestCase
139 139
 hardRayTest = (if castRay (10,0) (0,10) 5 sampleDensityFunction
140  
-	       then return (Passed "hardRayTest")
141  
-	       else return (Failed "hardRayTest"))
  140
+               then return (Passed "hardRayTest")
  141
+               else return (Failed "hardRayTest"))
142 142
 
143 143
 tooHardRayTest :: TestCase
144 144
 tooHardRayTest = (if castRay (10,0) (0,10) 4 sampleDensityFunction
145  
-		  then return (Failed "tooHardRayTest")
146  
-		  else return (Passed "tooHardRayTest"))
  145
+                  then return (Failed "tooHardRayTest")
  146
+                  else return (Passed "tooHardRayTest"))
147 147
 
148 148
 -- |
149 149
 -- This test should evaluate quickly, even though the ray is very long, because the ray
@@ -151,5 +151,5 @@ tooHardRayTest = (if castRay (10,0) (0,10) 4 sampleDensityFunction
151 151
 --
152 152
 stressLazyRayTest :: TestCase
153 153
 stressLazyRayTest = (if castRay (-1,0) (1,2500000) 2 sampleDensityFunction
154  
-		     then return (Failed "stressLazyRayTest")
155  
-		     else return (Passed "stressLazyRayTest"))
  154
+                     then return (Failed "stressLazyRayTest")
  155
+                     else return (Passed "stressLazyRayTest"))
54  Roguestar/Lib/HierarchicalDatabase.hs
@@ -100,8 +100,8 @@ lookupParent x the_map = fst $ lookup x the_map
100 100
 --
101 101
 childrenOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [Integer]
102 102
 childrenOf x the_map = maybe [] id $ Map.lookup x (hd_children the_map)
103  
-	
104  
-	
  103
+        
  104
+        
105 105
 -- |
106 106
 -- Converts a HierarchicalDatabase into a list of relations.
107 107
 --
@@ -123,46 +123,46 @@ instance HierarchicalRelation ExampleRelation where
123 123
 example1 :: HierarchicalDatabase ExampleRelation
124 124
 example1 = fromList $ List.map ExampleRelation 
125 125
                                                [(1,13,True),
126  
-						(1,(-5),True),
127  
-						(1,1,True),
128  
-						(1,7,True),
129  
-						(1,15,True),
130  
-						(2,0,False),
131  
-						(3,12,True),
132  
-						(3,9,False),
133  
-						(3,(-3),True),
134  
-						(4,100,False),
135  
-						(4,(-6),False),
136  
-						(4,14,False)]
  126
+                                                (1,(-5),True),
  127
+                                                (1,1,True),
  128
+                                                (1,7,True),
  129
+                                                (1,15,True),
  130
+                                                (2,0,False),
  131
+                                                (3,12,True),
  132
+                                                (3,9,False),
  133
+                                                (3,(-3),True),
  134
+                                                (4,100,False),
  135
+                                                (4,(-6),False),
  136
+                                                (4,14,False)]
137 137
 
138 138
 testParent :: TestCase
139 139
 testParent = if (parentOf 0 example1) == (Just 2)
140  
-	     then return (Passed "testParent")
141  
-	     else return (Failed "testParent")
  140
+             then return (Passed "testParent")
  141
+             else return (Failed "testParent")
142 142
 
143 143
 testChildren :: TestCase
144 144
 testChildren = if (length $ childrenOf 1 example1) == 5
145  
-	       then return (Passed "testChildren")
146  
-	       else return (Failed "testChildren")
  145
+               then return (Passed "testChildren")
  146
+               else return (Failed "testChildren")
147 147
 
148 148
 testUserData :: TestCase
149 149
 testUserData = let child_records = lookupChildren 1 example1
150  
-		   in if (all (\(ExampleRelation (_,_,b)) -> b) child_records)
151  
-		      then return (Passed "testUserDatas")
152  
-		      else return (Failed "testUserDatas")
  150
+                   in if (all (\(ExampleRelation (_,_,b)) -> b) child_records)
  151
+                      then return (Passed "testUserDatas")
  152
+                      else return (Failed "testUserDatas")
153 153
 
154 154
 testChildrenCorrect :: TestCase
155 155
 testChildrenCorrect = let the_children = childrenOf 4 example1
156  
-			  in if (all even the_children)
157  
-			     then return (Passed "testChildrenCorrect")
158  
-			     else return (Failed "testChildrenCorrect")
  156
+                          in if (all even the_children)
  157
+                             then return (Passed "testChildrenCorrect")
  158
+                             else return (Failed "testChildrenCorrect")
159 159
 
160 160
 testDelete :: TestCase
161 161
 testDelete = let deleted = delete 0 $ delete (-6) $ example1
162  
-		 in if ((length $ childrenOf 4 deleted) == 2 &&
163  
-			(isNothing $ parentOf 0 deleted))
164  
-		 then return (Passed "testDelete")
165  
-		 else return (Failed "testDelete")
  162
+                 in if ((length $ childrenOf 4 deleted) == 2 &&
  163
+                        (isNothing $ parentOf 0 deleted))
  164
+                 then return (Passed "testDelete")
  165
+                 else return (Failed "testDelete")
166 166
 
167 167
 insidenessTests :: [TestCase]
168 168
 insidenessTests = [testParent,testChildren,testUserData,testChildrenCorrect,testDelete]
45  Roguestar/Lib/Perception.hs
@@ -3,16 +3,20 @@
3 3
 -- | The Perception monad is a wrapper for roguestar's core
4 4
 -- monad that reveals only as much information as a character
5 5
 -- legitimately has.  Thus, it is suitable for writing AI
6  
--- routines as well as an API for the player's client.
  6
+-- routines as well as an API for the human player's client.
7 7
 module Roguestar.Lib.Perception
8 8
     (DBPerception,
9 9
      whoAmI,
10 10
      runPerception,
11 11
      VisibleObject(..),
  12
+     isVisibleTool,
  13
+     isVisibleCreature,
  14
+     isVisibleBuilding,
12 15
      stackVisibleObjects,
13 16
      visibleObjects,
14 17
      visibleTerrain,
15 18
      myFaction,
  19
+     myInventory,
16 20
      Roguestar.Lib.Perception.getCreatureFaction,
17 21
      whereAmI,
18 22
      Roguestar.Lib.Perception.whereIs,
@@ -46,11 +50,11 @@ import Roguestar.Lib.Building
46 50
 import Roguestar.Lib.SpeciesData
47 51
 import qualified Data.ByteString.Char8 as B
48 52
 import Roguestar.Lib.CreatureData
49  
-import Roguestar.Lib.CharacterData
50 53
 import qualified Data.Set as Set
51 54
 import qualified Data.Map as Map
52 55
 import Roguestar.Lib.Tool
53 56
 import Roguestar.Lib.ToolData
  57
+import Roguestar.Lib.PersistantData
54 58
 import qualified Roguestar.Lib.DetailedTravel as DT
55 59
 
56 60
 newtype (DBReadable db) => DBPerception db a = DBPerception { fromPerception :: (ReaderT CreatureRef db a) }
@@ -93,37 +97,54 @@ visibleTerrain =
93 97
 
94 98
 data VisibleObject =
95 99
     VisibleTool {
  100
+       visible_tool_ref :: ToolRef,
96 101
        visible_tool :: Tool,
97 102
        visible_object_position :: Position }
98 103
   | VisibleCreature {
  104
+       visible_creature_ref :: CreatureRef,
99 105
        visible_creature_species :: Species,
100 106
        visible_creature_character_classes :: [CharacterClass],
101  
-       visible_creature_wielding :: Maybe Tool,
  107
+       visible_creature_wielding :: Maybe VisibleObject,
102 108
        visible_object_position :: Position,
103 109
        visible_creature_faction :: Faction }
104 110
   | VisibleBuilding {
  111
+       visible_building_ref :: BuildingRef,
105 112
        visible_building_shape :: BuildingShape,
106 113
        visible_building_occupies :: MultiPosition,
107 114
        visible_object_position :: Position }
108 115
 
109  
-convertToVisibleObjectRecord :: (DBReadable db) => Reference () -> db VisibleObject
  116
+isVisibleTool :: VisibleObject -> Bool
  117
+isVisibleTool (VisibleTool {}) = True
  118
+isVisibleTool _ = False
  119
+
  120
+isVisibleCreature :: VisibleObject -> Bool
  121
+isVisibleCreature (VisibleCreature {}) = True
  122
+isVisibleCreature _ = False
  123
+
  124
+isVisibleBuilding :: VisibleObject -> Bool
  125
+isVisibleBuilding (VisibleBuilding {}) = True
  126
+isVisibleBuilding _ = False
  127
+
  128
+convertToVisibleObjectRecord :: (DBReadable db) => Reference a -> db VisibleObject
110 129
 convertToVisibleObjectRecord ref | (Just creature_ref) <- coerceReference ref =
111 130
     do species <- liftM creature_species $ dbGetCreature creature_ref
112 131
        classes <- liftM (Map.keys . creature_levels) $ dbGetCreature creature_ref
113 132
        faction <- Creature.getCreatureFaction creature_ref
114 133
        m_tool_ref <- getWielded creature_ref
  134
+       position <- liftM detail $ DT.whereIs creature_ref
115 135
        m_wielded <- case m_tool_ref of
116  
-           Just tool_ref -> liftM Just $ dbGetTool tool_ref
  136
+           Just tool_ref ->
  137
+               do tool <- dbGetTool tool_ref
  138
+                  return $ Just $ VisibleTool tool_ref tool position
117 139
            Nothing -> return Nothing
118  
-       position <- liftM detail $ DT.whereIs creature_ref
119  
-       return $ VisibleCreature species classes m_wielded position faction
  140
+       return $ VisibleCreature creature_ref species classes m_wielded position faction
120 141
 convertToVisibleObjectRecord ref | (Just tool_ref) <- coerceReference ref =
121 142
     do tool <- dbGetTool tool_ref
122 143
        position <- liftM detail $ getPlanarLocation tool_ref
123  
-       return $ VisibleTool tool position
  144
+       return $ VisibleTool tool_ref tool position
124 145
 convertToVisibleObjectRecord ref | (Just building_ref :: Maybe BuildingRef) <- coerceReference ref =
125 146
     do location <- DT.whereIs building_ref
126  
-       return $ VisibleBuilding (detail location) (detail location) (detail location)
  147
+       return $ VisibleBuilding building_ref (detail location) (detail location) (detail location)
127 148
 
128 149
 stackVisibleObjects :: [VisibleObject] -> Map Position [VisibleObject]
129 150
 stackVisibleObjects = foldr insertVob Map.empty
@@ -161,6 +182,12 @@ visibleObjects filterF =
161 182
            Nothing -> return []
162 183
        liftDB $ mapRO convertToVisibleObjectRecord visible_objects
163 184
 
  185
+myInventory :: (DBReadable db) => DBPerception db [VisibleObject]
  186
+myInventory =
  187
+    do me <- whoAmI
  188
+       (result :: [DetailedLocation Inventory]) <- liftDB $ liftM mapLocations $ DB.getContents me
  189
+       liftDB $ mapRO convertToVisibleObjectRecord $ sortBy (comparing toUID) $ (asChildren result :: [ToolRef])
  190
+
164 191
 myFaction :: (DBReadable db) => DBPerception db Faction
165 192
 myFaction = Roguestar.Lib.Perception.getCreatureFaction =<< whoAmI
166 193
 
13  Roguestar/Lib/PersistantData.hs
@@ -11,18 +11,7 @@ module Roguestar.Lib.PersistantData
11 11
 
12 12
 {----- CHARACTER -----}
13 13
 
14  
-data CharacterClass = Barbarian
15  
-                    | Consular
16  
-                    | Engineer
17  
-                    | ForceAdept
18  
-                    | Marine
19  
-                    | Ninja
20  
-                    | Pirate
21  
-                    | Scout
22  
-                    | Shepherd
23  
-                    | StarChild
24  
-                    | Thief
25  
-                    | Warrior
  14
+data CharacterClass = StarChild
26 15
                     deriving (Eq,Enum,Bounded,Read,Show,Ord)
27 16
 
28 17
 {----- POWER UPS -----}
2  Roguestar/Lib/PlayerState.hs
@@ -6,9 +6,9 @@ module Roguestar.Lib.PlayerState
6 6
 
7 7
 import Roguestar.Lib.DBData
8 8
 import Roguestar.Lib.CreatureData
9  
-import Roguestar.Lib.CharacterData
10 9
 import Roguestar.Lib.MakeData
11 10
 import Roguestar.Lib.TravelData
  11
+import Roguestar.Lib.PersistantData
12 12
 
13 13
 data PlayerState =
14 14
     SpeciesSelectionState (Maybe Creature)
785  Roguestar/Lib/Protocol.hs
... ...
@@ -1,785 +0,0 @@
1  
-{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, OverloadedStrings #-}
2  
-
3  
-module Protocol
4  
-    (mainLoop)
5  
-    where
6  
-
7  
-import Prelude hiding (getContents)
8  
-import Data.Char
9  
-import Reference
10  
-import Data.List as List
11  
-import CreatureData
12  
-import Creature
13  
-import Character
14  
-import DB
15  
-import System.Exit
16  
-import System.IO hiding (getContents)
17  
-import BeginGame
18  
-import Data.Maybe
19  
-import Plane
20  
-import PlaneData
21  
-import Building
22  
-import BuildingData
23  
-import Tool
24  
-import FactionData
25  
-import PlaneVisibility
26  
-import Facing
27  
-import ToolData
28  
-import Control.Monad.Error
29  
-import Turns
30  
-import SpeciesData
31  
-import Species
32  
-import Data.Ord
33  
-import Combat
34  
-import Substances
35  
-import PlayerState
36  
-import Make
37  
-import Control.Concurrent
38  
-import Control.Monad.STM
39  
-import Control.Concurrent.STM.TVar
40  
-import Control.Exception
41  
-import WorkCluster
42  
-import qualified Data.ByteString.Char8 as B
43  
-import qualified Perception
44  
-import DetailedLocation
45  
--- Don't call dbBehave, use dbPerformPlayerTurn
46  
-import Behavior hiding (dbBehave)
47  
--- We need to construct References based on UIDs, so we cheat a little:
48  
-import DBPrivate (Reference(ToolRef))
49  
-
50  
-mainLoop :: DB_BaseType -> IO ()
51  
-mainLoop db_init =
52  
-    do db_var <- newMVar db_init
53  
-       input_chan <- newChan
54  
-       output_chan <- newChan
55  
-       query_count <- newTVarIO (Just 0) -- Just (the number of running queries) or Nothing (a non-query action is in progress)
56  
-       wait_quit <- newEmptyMVar
57  
-       work_cluster <- newWorkCluster
58  
-       replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var
59  
-       let foreverLoopThenQuit = flip finally (putMVar wait_quit ()) . forever
60  
-       _ <- forkIO $ foreverLoopThenQuit $ writeChan input_chan =<< B.getLine  --read loop
61  
-       _ <- forkIO $ foreverLoopThenQuit $  --write loop
62  
-           do next_line <- liftM (B.map toLower . B.unlines . B.lines) (readChan output_chan)
63  
-              when (B.length next_line > 0) $
64  
-                  do B.putStrLn next_line
65  
-                     B.putStrLn "over"
66  
-              hFlush stdout
67  
-       _ <- forkIO $ foreverLoopThenQuit $
68  
-           -- read and dispatch commands, querys are run predictively
69  
-           -- (before they are actually received) and in parallel
70  
-           do next_command <- readChan input_chan
71  
-              case (B.words $ B.map toLower next_command) of
72  
-                  ["quit"] -> exitWith ExitSuccess
73  
-                  ["reset"] -> stopping query_count $ modifyMVar_ db_var (const $ return initial_db)
74  
-                  ("game":"query":args) ->
75  
-                      do querrying query_count $
76  
-                             do result <- workRequest work_cluster (Query, args)
77  
-                                complete Nothing output_chan result
78  
-                  ("game":"action":args) ->
79  
-                      do result <- workRequest work_cluster (Action, args)
80  
-                         stopping query_count $ complete (Just db_var) output_chan result
81  
-                         querrying query_count $ complete Nothing output_chan result -- print the result as a query, this will ensure errors get printed
82  
-                         replaceWorkOperation work_cluster . evaluateGame =<< readMVar db_var
83  
-                  ("noop":_) -> return ()
84  
-                  failed -> 
85  
-                      do _ <- forkIO $ complete Nothing output_chan $ Left $ DBError $ "protocol-error: unrecognized request: `" ++ B.unpack (B.unwords failed) ++ "`"
86  
-                         return ()
87  
-       takeMVar wait_quit -- "park" the main function
88  
-
89  
--- | Evaluate a 'GameDirective' and return it from a remote thread via an 'MVar'.
90  
-evaluateGame :: DB_BaseType -> WorkRequest -> IO WorkResult
91  
-evaluateGame db0 (Query, ["snapshot"]) = (runDB $ ro $ liftM (\b -> "answer: snapshot " `B.append` if b then "yes" else "no") dbHasSnapshot) db0
92  
-evaluateGame db0 (Query, args) = (runDB $ ro $ dbPeepOldestSnapshot $ dbDispatchQuery args) db0
93  
-evaluateGame db0 (Action, args) = runDB (liftM (const "") $ dbDispatchAction args) db0
94  
-
95  
--- | Wait for currently running queries to finish, and stop processing incomming queries while we mutate the database.
96  
-stopping :: TVar (Maybe Integer) -> IO () -> IO ()
97  
-stopping query_count actionM = bracket
98  
-    (atomically $ do maybe retry (\x -> when (x /= 0) retry) =<< readTVar query_count
99  
-                     writeTVar query_count $ Nothing)
100  
-    (const $ atomically $ writeTVar query_count (Just 0))
101  
-    (const actionM)
102  
-
103  
--- | Process a querry concurrently with other queries.
104  
-querrying :: TVar (Maybe Integer) -> IO () -> IO ()
105  
-querrying query_count actionM =
106  
-    do atomically $ writeTVar query_count =<< liftM Just . (maybe retry $ return . (+1)) =<< readTVar query_count
107  
-       _ <- forkIO $ finally (atomically $ do writeTVar query_count =<< liftM (fmap (subtract 1)) (readTVar query_count)) actionM
108  
-       return ()
109  
-
110  
--- | Complete a querry or action.  If a database variable is provided, it will be modified according to the result of the action.
111  
--- The result of the action will be printed to the output_chan.
112  
-complete :: Maybe (MVar DB_BaseType) -> Chan B.ByteString -> Either DBError (B.ByteString,DB_BaseType) -> IO ()
113  
-complete m_db_var output_chan result =
114  
-    do case m_db_var of
115  
-           Just db_var -> 
116  
-               do modifyMVar_ db_var $ \db0 -> return $ case result of
117  
-                      Right (_,db1) -> db1
118  
-                      Left (DBErrorFlag errflag) -> db0 { db_error_flag = show errflag }
119  
-                      Left (DBError _) -> db0
120  
-                  writeChan output_chan "done"
121  
-           Nothing ->
122  
-               do case result of
123  
-                      Right (outstr,_) ->
124  
-                          do _ <- evaluate outstr
125  
-                             writeChan output_chan outstr
126  
-                      Left (DBErrorFlag _) -> return () -- client will query this explicitly (if it cares)
127  
-                      Left (DBError errstr) ->
128  
-                          do writeChan output_chan $ "error: " `B.append` B.pack errstr
129  
-                             B.hPutStrLn stderr $ "DBError: " `B.append` B.pack errstr
130  
-
131  
-dbOldestSnapshotOnly :: (DBReadable db) => db ()
132  
-dbOldestSnapshotOnly = 
133  
-    do b <- dbHasSnapshot
134  
-       when b $ fail "protocol-error: pending snapshot"
135  
-
136  
--- |
137  
--- Perform an action assuming the database is in the DBRaceSelectionState,
138  
--- otherwise returns an error message.
139  
---
140  
-dbRequiresSpeciesSelectionState :: (DBReadable db) => db a -> db a
141  
-dbRequiresSpeciesSelectionState action =
142  
-    do dbOldestSnapshotOnly
143  
-       state <- playerState
144  
-       case state of
145  
-           SpeciesSelectionState -> action
146  
-           _ -> throwError $ DBError $ "protocol-error: not in species selection state (" ++ show state ++ ")"
147  
-
148  
--- |
149  
--- Perform an action assuming the database is in the DBClassSelectionState,
150  
--- otherwise returns an error message.
151  
---
152  
-dbRequiresClassSelectionState :: (DBReadable db) => (Creature -> db a) -> db a
153  
-dbRequiresClassSelectionState action =
154  
-    do dbOldestSnapshotOnly
155  
-       state <- playerState
156  
-       case state of
157  
-           ClassSelectionState creature -> action creature
158  
-           _ -> throwError $ DBError $ "protocol-error: not in class selection state (" ++ show state ++ ")"
159  
-
160  
--- |
161  
--- Perform an action that operates on the player creature (not in any context).
162  
--- The states that work for this are:
163  
---
164  
--- * ClassSelectionState
165  
--- * PlayerCreatureTurn
166  
---
167  
-dbRequiresPlayerCenteredState :: (DBReadable db) => (Creature -> db a) -> db a
168  
-dbRequiresPlayerCenteredState action =
169  
-    do dbOldestSnapshotOnly
170  
-       state <- playerState
171  
-       case state of
172  
-                  ClassSelectionState creature -> action creature
173  
-                  PlayerCreatureTurn creature_ref _ -> action =<< dbGetCreature creature_ref
174  
-                  _ -> throwError $ DBError $ "protocol-error: not in player-centered state (" ++ show state ++ ")"
175  
-
176  
--- |
177  
--- Perform an action that works during any creature's turn in a planar environment.
178  
--- The states that work for this are:
179  
---
180  
--- * PlayerCreatureTurn
181  
--- * SnapshotEvent
182  
---
183  
-dbRequiresPlanarTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a
184  
-dbRequiresPlanarTurnState action =
185  
-    do dbOldestSnapshotOnly
186  
-       state <- playerState
187  
-       maybe (throwError $ DBError $ "protocol-error: not in planar turn state (" ++ show state ++ ")") action $ creatureOf state
188  
-
189  
--- |
190  
--- Perform an action that works only during a player-character's turn.
191  
--- The states that work for this are:
192  
---
193  
--- PlayerCreatureTurn
194  
---
195  
-dbRequiresPlayerTurnState :: (DBReadable db) => (CreatureRef -> db a) -> db a
196  
-dbRequiresPlayerTurnState action =
197  
-    do dbOldestSnapshotOnly
198  
-       state <- playerState
199  
-       case state of
200  
-                  PlayerCreatureTurn creature_ref _ -> action creature_ref
201  
-                  _ -> throwError $ DBError $ "protocol-error: not in player turn state (" ++ show state ++ ")"
202  
-
203  
--- |
204  
--- For arbitrary-length menu selections, get the current index into the menu, if any.
205  
---
206  
-menuState :: (DBReadable db) => db (Maybe Integer)
207  
-menuState = liftM menuIndex playerState
208  
-
209  
--- |
210  
--- For arbitrary-length menu selections, modify the current index into the menu.  If there is no menu index
211  
--- in the current state, this has no effect.
212  
---
213  
-modifyMenuState :: (Integer -> Integer) -> DB ()
214  
-modifyMenuState f_ =
215  
-    do number_of_tools <- liftM genericLength toolMenuElements
216  
-       let f = (\x -> if number_of_tools == 0 then 0 else x `mod` number_of_tools) . f_
217  
-       setPlayerState . modifyMenuIndex f =<< playerState
218  
-
219  
-dbDispatchQuery :: (DBReadable db) => [B.ByteString] -> db B.ByteString
220  
-dbDispatchQuery ["state"] =
221  
-    do state <- playerState
222  
-       return $ case state of
223  
-                           SpeciesSelectionState -> "answer: state species-selection"
224  
-                           ClassSelectionState {} -> "answer: state class-selection"
225  
-                           PlayerCreatureTurn _ NormalMode -> "answer: state player-turn"
226  
-                           PlayerCreatureTurn _ MoveMode -> "answer: state move"
227  
-                           PlayerCreatureTurn _ (PickupMode {}) -> "answer: state pickup"
228  
-                           PlayerCreatureTurn _ (DropMode {}) -> "answer: state drop"
229  
-                           PlayerCreatureTurn _ (WieldMode {}) -> "answer: state wield"
230  
-                           PlayerCreatureTurn _ AttackMode -> "answer: state attack"
231  
-                           PlayerCreatureTurn _ FireMode -> "answer: state fire"
232  
-                           PlayerCreatureTurn _ JumpMode -> "answer: state jump"
233  
-                           PlayerCreatureTurn _ TurnMode -> "answer: state turn"
234  
-                           PlayerCreatureTurn _ (MakeMode _ make_prep) | isFinished make_prep -> "answer: state make-finished"
235  
-                           PlayerCreatureTurn _ (MakeMode _ make_prep) | needsKind make_prep -> "answer: state make-what"
236  
-                           PlayerCreatureTurn _ (MakeMode {}) -> "answer: state make"
237  
-                           PlayerCreatureTurn _ ClearTerrainMode -> "answer: state clear-terrain"
238  
-                           SnapshotEvent (AttackEvent {}) -> "answer: state attack-event"
239  
-                           SnapshotEvent (MissEvent {}) -> "answer: state miss-event"
240  
-                           SnapshotEvent (KilledEvent {}) -> "answer: state killed-event"
241  
-                           SnapshotEvent (WeaponOverheatsEvent {}) -> "answer: state weapon-overheats-event"
242  
-                           SnapshotEvent (WeaponExplodesEvent {}) -> "answer: state weapon-explodes-event"
243  
-                           SnapshotEvent (DisarmEvent {}) -> "answer: state disarm-event"
244  
-                           SnapshotEvent (SunderEvent {}) -> "answer: state sunder-event"
245  
-                           SnapshotEvent (TeleportEvent {}) -> "answer: state teleport-event"
246  
-                           SnapshotEvent (HealEvent {}) -> "answer: state heal-event"
247  
-                           SnapshotEvent (ClimbEvent {}) -> "answer: state climb-event"
248  
-                           SnapshotEvent (ExpendToolEvent {}) -> "answer: state expend-tool-event"
249  
-                           SnapshotEvent (BumpEvent {}) -> "answer: state bump-event"
250  
-                           GameOver -> "answer: state game-over"
251  
-
252  
-dbDispatchQuery ["action-count"] =
253  
-    do n <- dbActionCount
254  
-       return $ "answer: action-count " `B.append` (B.pack $ show n)
255  
-
256  
-dbDispatchQuery ["menu-state"] =
257  
-    do m_state <- menuState
258  
-       return $ case m_state of
259  
-           Nothing -> "answer: menu-state 0"
260  
-           Just state -> "answer: menu-state " `B.append` (B.pack $ show state)
261  
-
262  
-dbDispatchQuery ["who-attacks"] =
263  
-    do state <- playerState
264  
-       return $ case state of
265  
-           SnapshotEvent (AttackEvent { attack_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
266  
-	   SnapshotEvent (MissEvent { miss_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
267  
-           SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
268  
-           SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
269  
-           SnapshotEvent (DisarmEvent { disarm_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
270  
-           SnapshotEvent (SunderEvent { sunder_event_source_creature = attacker_ref }) -> "answer: who-attacks " `B.append` (B.pack $ show $ toUID attacker_ref)
271  
-	   _ -> "answer: who-attacks 0"
272  
-
273  
-dbDispatchQuery ["who-hit"] =
274  
-    do state <- playerState
275  
-       return $ case state of
276  
-           SnapshotEvent (AttackEvent { attack_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
277  
-           SnapshotEvent (DisarmEvent { disarm_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
278  
-           SnapshotEvent (SunderEvent { sunder_event_target_creature = target_ref }) -> "answer: who-hit " `B.append` (B.pack $ show $ toUID target_ref)
279  
-	   _ -> "answer: who-hit 0"
280  
-
281  
-dbDispatchQuery ["tool-used"] =
282  
-    do state <- playerState
283  
-       return $ case state of
284  
-           SnapshotEvent (ExpendToolEvent { expend_tool_event_tool = tool_ref }) -> "answer: tool-used " `B.append` (B.pack $ show $ toUID tool_ref)
285  
-           _ -> "answer: tool-used 0"
286  
-
287  
-dbDispatchQuery ["weapon-used"] =
288  
-    do state <- playerState
289  
-       return $ case state of
290  
-           SnapshotEvent (AttackEvent { attack_event_source_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
291  
-	   SnapshotEvent (MissEvent { miss_event_weapon = Just weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
292  
-           SnapshotEvent (WeaponOverheatsEvent { weapon_overheats_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
293  
-           SnapshotEvent (WeaponExplodesEvent { weapon_explodes_event_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
294  
-           SnapshotEvent (SunderEvent { sunder_event_source_weapon = weapon_ref }) -> "answer: weapon-used " `B.append` (B.pack $ show $ toUID weapon_ref)
295  
-	   _ -> "answer: weapon-used 0"
296  
-
297  
-dbDispatchQuery ["tool-hit"] =
298  
-    do state <- playerState
299  
-       return $ case state of
300  
-           SnapshotEvent (DisarmEvent { disarm_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)
301  
-           SnapshotEvent (SunderEvent { sunder_event_target_tool = tool_ref }) -> "answer: tool-hit " `B.append` (B.pack $ show $ toUID tool_ref)
302  
-           _ -> "answer: tool-hit 0"
303  
-
304  
-dbDispatchQuery ["who-killed"] =
305  
-    do state <- playerState
306  
-       return $ case state of
307  
-           SnapshotEvent (KilledEvent killed_ref) -> "answer: who-killed " `B.append` (B.pack $ show $ toUID killed_ref)
308  
-	   _ -> "answer: who-killed 0"
309  
-
310  
-dbDispatchQuery ["who-event"] =
311  
-    do state <- playerState
312  
-       return $ case state of
313  
-           SnapshotEvent event -> "answer: who-event " `B.append` fromMaybe "0" (fmap (B.pack . show . toUID) $ subjectOf event)
314  
-           _ -> "answer: who-event 0"
315  
-
316  
-dbDispatchQuery ["new-level"] =
317  
-    do state <- playerState
318  
-       return $ case state of
319  
-           SnapshotEvent event -> "answer: new-level " `B.append` maybe "nothing" (B.pack . show) (bump_event_new_level event)
320  
-           _ -> "answer: new-level nothing"
321  
-
322  
-dbDispatchQuery ["new-character-class"] =
323  
-    do state <- playerState
324  
-       return $ case state of
325  
-           SnapshotEvent event -> "answer: new-character-class " `B.append` maybe "nothing" (B.pack . show) (bump_event_new_class event)
326  
-           _ -> "answer: new-character-class nothing"
327  
-
328  
-dbDispatchQuery ["player-species","0"] =
329  
-    return ("begin-table player-species 0 name\n" `B.append`
330  
-            B.unlines (map B.pack player_species_names) `B.append`
331  
-            "end-table")
332  
-
333  
-dbDispatchQuery ["visible-terrain","0"] =
334  
-    do maybe_plane_ref <- dbGetCurrentPlane
335  
-       terrain_map <- maybe (return []) (dbGetVisibleTerrainForFaction Player) maybe_plane_ref 
336  
-       return ("begin-table visible-terrain 0 x y terrain-type\n" `B.append`
337  
-	       (B.unlines $ map (\(terrain_type,Position (x,y)) -> B.unwords $ map B.pack [show x, show y, show terrain_type]) terrain_map) `B.append`
338  
-	       "end-table")
339  
-
340  
-dbDispatchQuery ["who-player"] = return "answer: who-player 2"
341  
-
342  
-dbDispatchQuery ["visible-objects","0"] =
343  
-    do maybe_plane_ref <- dbGetCurrentPlane
344  
-       (objects :: [Reference ()]) <- maybe (return [])
345  
-           (dbGetVisibleObjectsForFaction (return . const True) Player) maybe_plane_ref
346  
-       table_rows <- mapM dbObjectToTableRow objects
347  
-       return ("begin-table visible-objects 0 object-unique-id x y facing\n" `B.append`
348  
-               (B.unlines $ table_rows) `B.append`
349  
-               "end-table")
350  
-        where dbObjectToTableRow obj_ref =
351  
-                do l <- whereIs obj_ref
352  
-                   return $ case (fromLocation l,fromLocation l) of
353  
-                                 (Just (Position (x,y)),maybe_face) -> B.unwords $ map B.pack $ [show $ toUID obj_ref,show x,show y,show $ fromMaybe Here maybe_face]
354  
-                                 _ -> ""
355  
-
356  
-dbDispatchQuery ["object-details",uid] = ro $
357  
-  do maybe_plane_ref <- dbGetCurrentPlane
358  
-     (visibles :: [Reference ()]) <- maybe
359  
-         (return [])
360  
-         (dbGetVisibleObjectsForFaction (\ref ->
361  
-              do let f = (== uid) . B.pack . show . toUID
362  
-                 let m_wielder = coerceReference ref
363  
-                 m_wield <- maybe (return Nothing) getWielded m_wielder
364  
-                 return $ maybe False f m_wield || f ref) Player)
365  
-         maybe_plane_ref
366  
-     let (creature_refs :: [CreatureRef]) = mapMaybe coerceReference visibles
367  
-     wielded <- liftM catMaybes $ mapM getWielded creature_refs
368  
-     let (tool_refs :: [ToolRef]) = mapMaybe coerceReference visibles ++ wielded
369  
-     let (building_refs :: [BuildingRef]) = mapMaybe coerceReference visibles
370  
-     creatures <- liftM (zip creature_refs) $ mapRO dbGetCreature creature_refs
371  
-     tools <- liftM (zip tool_refs) $ mapRO dbGetTool tool_refs
372  
-     buildings <- liftM (zip building_refs) $ mapRO dbGetBuilding building_refs
373  
-     liftM B.unlines $ liftM3 (\a b c -> concat [a,b,c])
374  
-                            (mapM creatureToTableData creatures)
375  
-                            (mapM toolToTableData tools)
376  
-                            (mapM buildingToTableData buildings)
377  
-   where objectTableWrapper :: (DBReadable db) =>
378  
-                               Reference a ->
379  
-                               db B.ByteString ->
380  
-                               db B.ByteString
381  
-         objectTableWrapper obj_ref tableDataF =
382  
-          do table_data <- tableDataF
383  
-             return $
384  
-                 "begin-table object-details " `B.append`
385  
-                 (B.pack $ show $ toUID obj_ref) `B.append`
386  
-                 " property value\n" `B.append`
387  
-                 table_data `B.append`
388  
-                 "end-table"
389  
-         creatureToTableData :: (DBReadable db) =>
390  
-                                (CreatureRef,Creature) ->
391  
-                                db B.ByteString
392  
-         creatureToTableData (ref,creature) = objectTableWrapper ref $
393  
-            do fac <- getCreatureFaction ref
394  
-               hp <- getCreatureAbsoluteHealth ref
395  
-               maxhp <- getCreatureMaxHealth ref
396  
-               return $
397  
-                   "object-type creature\n" `B.append`
398  
-                   "species " `B.append` (B.pack $ show $ creature_species creature) `B.append` "\n" `B.append`
399  
-                   "random-id " `B.append` (B.pack $ show $ creature_random_id creature) `B.append` "\n" `B.append`
400  
-                   "faction " `B.append` B.pack (show fac) `B.append` "\n" `B.append`
401  
-                       (if fac == Player then
402  
-                           "hp " `B.append` B.pack (show hp) `B.append` "\n" `B.append`
403  
-                           "maxhp " `B.append` B.pack (show maxhp) `B.append` "\n"
404  
-                        else "")
405  
-         toolToTableData :: (DBReadable db) => (ToolRef,Tool) -> db B.ByteString
406  
-         toolToTableData (ref,tool) = objectTableWrapper ref $ return $
407  
-               "object-type tool\n" `B.append`
408  
-               "tool-type " `B.append` toolType tool `B.append` "\n" `B.append`
409  
-               "tool " `B.append` toolName tool `B.append` "\n"
410  
-         buildingToTableData :: (DBReadable db) => (BuildingRef,Building) -> db B.ByteString
411  
-         buildingToTableData (ref,Building {}) = objectTableWrapper ref $
412  
-             do building_shape <- buildingShape ref
413  
-                return $ "object-type building\n" `B.append`
414  
-                         "building-shape " `B.append` B.pack (show building_shape) `B.append` "\n"
415  
-
416  
-dbDispatchQuery ["player-stats","0"] = dbRequiresPlayerCenteredState dbQueryPlayerStats
417  
-
418  
-dbDispatchQuery ["center-coordinates","0"] = dbRequiresPlanarTurnState dbQueryCenterCoordinates
419  
-
420  
-dbDispatchQuery ["base-classes","0"] = dbRequiresClassSelectionState dbQueryBaseClasses
421  
-
422  
-dbDispatchQuery ["pickups","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
423  
-    liftM (showToolMenuTable "pickups" "0") $ toolsToMenuTable =<< availablePickups creature_ref
424  
-
425  
-dbDispatchQuery ["inventory","0"] = dbRequiresPlayerTurnState $ \creature_ref ->
426  
-    do inventory <- liftM (map asChild . mapLocations) $ getContents creature_ref
427  
-       liftM (showToolMenuTable "inventory" "0") $ toolsToMenuTable inventory
428  
-
429  
-dbDispatchQuery ["menu","0"] =
430  
-    liftM (showToolMenuTable "menu" "0") $ toolsToMenuTable =<< toolMenuElements
431  
-
432  
-dbDispatchQuery ["menu",s] | Just window_size <- readNumber s =
433  
-    do -- constructs a scrolling window of menu items
434  
-       -- FIXME!  This should be done client side.
435  
-       n <- liftM (fromMaybe 0) menuState
436  
-       l <- menuLength
437  
-       let half_window = window_size `div` 2
438  
-       let window_top = max 0 $ min (l-window_size-1) (n - half_window)
439  
-       let windowFilter (x,_,_) = x >= window_top && x <= window_top + window_size
440  
-       liftM (showToolMenuTable "menu" s . filter windowFilter) $ toolsToMenuTable =<< toolMenuElements
441  
-
442  
-dbDispatchQuery ["wielded-objects","0"] =
443  
-    do m_plane_ref <- dbGetCurrentPlane
444  
-       visible_refs <- maybe (return []) (dbGetVisibleObjectsForFaction (return . const True) Player) m_plane_ref
445  
-       let (creature_refs :: [CreatureRef]) = mapMaybe coerceReference visible_refs
446  
-       wielded_tool_refs <- mapM getWielded creature_refs
447  
-       let wieldedPairToTable :: CreatureRef -> Maybe ToolRef -> Maybe B.ByteString
448  
-           wieldedPairToTable creature_ref = fmap (\tool_ref -> (B.pack $ show $ toUID tool_ref) `B.append` " " `B.append` (B.pack $ show $ toUID creature_ref))
449  
-       return $ "begin-table wielded-objects 0 uid creature\n" `B.append`
450  
-                B.unlines (catMaybes $ zipWith wieldedPairToTable creature_refs wielded_tool_refs) `B.append`
451  
-                "end-table"
452  
-