Getting to be a fairly acceptable web game.

parent 57bc4461
......@@ -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
......
......@@ -13,7 +13,6 @@ module Roguestar.Lib.BuildingData
where
import Roguestar.Lib.PowerUpData
import Roguestar.Lib.CharacterData
import Roguestar.Lib.PersistantData
basic_stargate :: BuildingPrototype
......
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
......@@ -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,
......
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]
......@@ -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
......@@ -184,12 +175,6 @@ creatureAbilityScore InventorySkill = figureAbility [Strength,Speed,Constitution
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
......
......@@ -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 }
......@@ -22,28 +22,28 @@ 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.
......@@ -51,13 +51,13 @@ castRays src@(src_x,src_y) dests opacityFn =
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,18 +132,18 @@ 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
......@@ -151,5 +151,5 @@ tooHardRayTest = (if castRay (10,0) (0,10) 4 sampleDensityFunction
--
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"))
......@@ -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]
......@@ -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
......
......@@ -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 -----}
......
......@@ -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)
......
This diff is collapsed.
{-# 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 write