Renders a map on the server.

parent 0cb22b5a
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Roguestar.Lib.BeginGame module Roguestar.Lib.BeginGame
(dbBeginGame) (beginGame)
where where
import Roguestar.Lib.Plane import Roguestar.Lib.Plane
...@@ -13,6 +13,7 @@ import Roguestar.Lib.Facing ...@@ -13,6 +13,7 @@ import Roguestar.Lib.Facing
import Roguestar.Lib.TerrainData import Roguestar.Lib.TerrainData
import Roguestar.Lib.ToolData import Roguestar.Lib.ToolData
import Control.Monad import Control.Monad
import Control.Monad.Error
import Roguestar.Lib.SpeciesData import Roguestar.Lib.SpeciesData
import Roguestar.Lib.Substances as Substances import Roguestar.Lib.Substances as Substances
import Roguestar.Lib.PlayerState import Roguestar.Lib.PlayerState
...@@ -36,20 +37,6 @@ homeBiome Recreant = TundraBiome ...@@ -36,20 +37,6 @@ homeBiome Recreant = TundraBiome
homeBiome Reptilian = ForestBiome homeBiome Reptilian = ForestBiome
homeBiome DustVortex = DesertBiome homeBiome DustVortex = DesertBiome
startingEquipmentByClass :: CharacterClass -> [Tool]
startingEquipmentByClass Barbarian = [kinetic_fleuret]
startingEquipmentByClass Consular = [sphere Silver]
startingEquipmentByClass Engineer = [sphere Crudnium,sphere Molybdenum,sphere Uranium]
startingEquipmentByClass ForceAdept = [kinetic_sabre]
startingEquipmentByClass Marine = [phase_pistol,phase_rifle]
startingEquipmentByClass Ninja = []
startingEquipmentByClass Pirate = [phaser]
startingEquipmentByClass Scout = [phase_pistol]
startingEquipmentByClass Shepherd = [sphere Wood]
startingEquipmentByClass Thief = [sphere Platinum]
startingEquipmentByClass Warrior = [phaser,kinetic_fleuret]
startingEquipmentByClass StarChild = [sphere Diamond]
startingEquipmentBySpecies :: Species -> [Tool] startingEquipmentBySpecies :: Species -> [Tool]
startingEquipmentBySpecies Anachronid = [sphere Radon] startingEquipmentBySpecies Anachronid = [sphere Radon]
startingEquipmentBySpecies Ascendant = [sphere Neon] startingEquipmentBySpecies Ascendant = [sphere Neon]
...@@ -69,21 +56,24 @@ dbCreateStartingPlane :: Creature -> DB PlaneRef ...@@ -69,21 +56,24 @@ dbCreateStartingPlane :: Creature -> DB PlaneRef
dbCreateStartingPlane creature = dbCreateStartingPlane creature =
do dbNewPlane "belhaven" (TerrainGenerationData { do dbNewPlane "belhaven" (TerrainGenerationData {
tg_smootheness = 3, tg_smootheness = 3,
tg_biome = homeBiome $ creature_species creature, tg_biome = homeBiome $ creature_species creature,
tg_placements = [] }) TheUniverse tg_placements = [] }) TheUniverse
-- | -- |
-- Begins the game with the specified starting player creature and the specified starting character class. -- Begins the game with the specified starting player creature.
-- The character class should not be pre-applied to the creature.
-- --
dbBeginGame :: Creature -> CharacterClass -> DB () beginGame :: DB ()
dbBeginGame creature character_class = beginGame =
do let first_level_creature = applyCharacterClass character_class creature do player_state <- playerState
creature <- case player_state of
SpeciesSelectionState (Just c) -> return c
_ -> throwError $ DBError "Tried to begin a game, but no species/creature has been selected."
plane_ref <- dbCreateStartingPlane creature plane_ref <- dbCreateStartingPlane creature
landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref landing_site <- pickRandomClearSite 200 30 2 (Position (0,0)) (not . (`elem` difficult_terrains)) plane_ref
creature_ref <- dbAddCreature first_level_creature (Standing plane_ref landing_site Here) creature_ref <- dbAddCreature creature (Standing plane_ref landing_site Here)
setPlayerCreature creature_ref
_ <- createTown plane_ref [basic_stargate,monolith] _ <- createTown plane_ref [basic_stargate,monolith]
let starting_equip = startingEquipmentBySpecies (creature_species creature) ++ startingEquipmentByClass character_class let starting_equip = startingEquipmentBySpecies (creature_species creature)
forM_ starting_equip $ \tool -> dbAddTool tool (Inventory creature_ref) forM_ starting_equip $ \tool -> dbAddTool tool (Inventory creature_ref)
forM_ [0..10] $ \_ -> do tool_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref forM_ [0..10] $ \_ -> do tool_position <- pickRandomClearSite 200 1 2 landing_site (not . (`elem` difficult_terrains)) plane_ref
tool_type <- weightedPickM [(8,phase_pistol),(5,phaser),(3,phase_rifle),(8,kinetic_fleuret),(3,kinetic_sabre), tool_type <- weightedPickM [(8,phase_pistol),(5,phaser),(3,phase_rifle),(8,kinetic_fleuret),(3,kinetic_sabre),
...@@ -92,5 +82,5 @@ dbBeginGame creature character_class = ...@@ -92,5 +82,5 @@ dbBeginGame creature character_class =
(_,end_of_nonaligned_first_series) <- makePlanets (Subsequent plane_ref NonAlignedRegion) =<< generatePlanetInfo nonaligned_first_series_planets (_,end_of_nonaligned_first_series) <- makePlanets (Subsequent plane_ref NonAlignedRegion) =<< generatePlanetInfo nonaligned_first_series_planets
_ <- makePlanets (Subsequent end_of_nonaligned_first_series NonAlignedRegion) =<< generatePlanetInfo nonaligned_second_series_planets _ <- makePlanets (Subsequent end_of_nonaligned_first_series NonAlignedRegion) =<< generatePlanetInfo nonaligned_second_series_planets
_ <- makePlanets (Subsequent end_of_nonaligned_first_series CyborgRegion) =<< generatePlanetInfo cyborg_planets _ <- makePlanets (Subsequent end_of_nonaligned_first_series CyborgRegion) =<< generatePlanetInfo cyborg_planets
setPlayerState $ PlayerCreatureTurn creature_ref NormalMode setPlayerState $ PlayerCreatureTurn creature_ref
...@@ -42,13 +42,12 @@ generateCreature :: Faction -> Species -> DB Creature ...@@ -42,13 +42,12 @@ generateCreature :: Faction -> Species -> DB Creature
generateCreature faction species = generateAttributes faction species $ mconcat $ species_starting_attributes $ speciesInfo species generateCreature faction species = generateAttributes faction species $ mconcat $ species_starting_attributes $ speciesInfo species
-- | -- |
-- During DBRaceSelectionState, generates a new Creature for the player character and sets it into the -- During DBRaceSelectionState, generates a new Creature for the player character.
-- database's DBClassSelectionState.
-- --
generateInitialPlayerCreature :: Species -> DB () generateInitialPlayerCreature :: Species -> DB ()
generateInitialPlayerCreature species = generateInitialPlayerCreature species =
do newc <- generateCreature Player species do newc <- generateCreature Player species
setStartingSpecies species setPlayerState $ SpeciesSelectionState $ Just newc
-- | -- |
-- Generates a new Creature from the specified Species and adds it to the database. -- Generates a new Creature from the specified Species and adds it to the database.
...@@ -95,7 +94,7 @@ getTerrainAffinity creature_ref = ...@@ -95,7 +94,7 @@ getTerrainAffinity creature_ref =
-- | Get the current creature, if it belongs to the specified faction, based on the current playerState. -- | Get the current creature, if it belongs to the specified faction, based on the current playerState.
getCurrentCreature :: (DBReadable db) => Faction -> db (Maybe CreatureRef) getCurrentCreature :: (DBReadable db) => Faction -> db (Maybe CreatureRef)
getCurrentCreature faction = getCurrentCreature faction =
do m_who <- liftM creatureOf $ playerState do m_who <- liftM subjectOf $ playerState
is_one_of_us <- maybe (return False) (liftM (== faction) . getCreatureFaction) m_who is_one_of_us <- maybe (return False) (liftM (== faction) . getCreatureFaction) m_who
return $ if is_one_of_us then m_who else Nothing return $ if is_one_of_us then m_who else Nothing
......
...@@ -13,8 +13,9 @@ module Roguestar.Lib.DB ...@@ -13,8 +13,9 @@ module Roguestar.Lib.DB
DBReadable(..), DBReadable(..),
playerState, playerState,
setPlayerState, setPlayerState,
getPlayerCreature,
setPlayerCreature,
SnapshotEvent(..), SnapshotEvent(..),
DBError(..),
initial_db, initial_db,
DB_BaseType(db_error_flag), DB_BaseType(db_error_flag),
dbActionCount, dbActionCount,
...@@ -37,8 +38,6 @@ module Roguestar.Lib.DB ...@@ -37,8 +38,6 @@ module Roguestar.Lib.DB
whereIs, whereIs,
getContents, getContents,
move, move,
setStartingSpecies,
getStartingSpecies,
ro, atomic, ro, atomic,
logDB, logDB,
mapRO, filterRO, sortByRO, mapRO, filterRO, sortByRO,
...@@ -89,8 +88,8 @@ data DB_History = DB_History { ...@@ -89,8 +88,8 @@ data DB_History = DB_History {
data DB_BaseType = DB_BaseType { db_player_state :: PlayerState, data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
db_next_object_ref :: Integer, db_next_object_ref :: Integer,
db_starting_species :: Maybe Species,
db_creatures :: Map CreatureRef Creature, db_creatures :: Map CreatureRef Creature,
db_player_creature :: Maybe CreatureRef,
db_planes :: Map PlaneRef Plane, db_planes :: Map PlaneRef Plane,
db_tools :: Map ToolRef Tool, db_tools :: Map ToolRef Tool,
db_buildings :: Map BuildingRef Building, db_buildings :: Map BuildingRef Building,
...@@ -101,14 +100,6 @@ data DB_BaseType = DB_BaseType { db_player_state :: PlayerState, ...@@ -101,14 +100,6 @@ data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
db_action_count :: Integer } db_action_count :: Integer }
deriving (Read,Show) deriving (Read,Show)
data DBError =
DBError String
| DBErrorFlag ErrorFlag
deriving (Read,Show)
instance Error DBError where
strMsg = DBError
type DBResult r = Either DBError (r,DB_History) type DBResult r = Either DBError (r,DB_History)
data DB a = DB { cycleDB :: forall r. DB_History -> (a -> DB_History -> DBResult r) -> DBResult r } data DB a = DB { cycleDB :: forall r. DB_History -> (a -> DB_History -> DBResult r) -> DBResult r }
...@@ -120,7 +111,7 @@ runDB dbAction database = ...@@ -120,7 +111,7 @@ runDB dbAction database =
instance Monad DB where instance Monad DB where
return a = DB $ \h f -> f a h return a = DB $ \h f -> f a h
k >>= m = DB $ \h f -> cycleDB k h $ \a h' -> cycleDB (m a) h' f k >>= m = DB $ \h f -> cycleDB k h $ \a h' -> cycleDB (m a) h' f
fail = error fail = throwError . DBError
instance Functor DB where instance Functor DB where
fmap = liftM fmap = liftM
...@@ -212,10 +203,10 @@ atomic action ro_action = ...@@ -212,10 +203,10 @@ atomic action ro_action =
-- --
initial_db :: DB_BaseType initial_db :: DB_BaseType
initial_db = DB_BaseType { initial_db = DB_BaseType {
db_player_state = SpeciesSelectionState, db_player_state = SpeciesSelectionState Nothing,
db_next_object_ref = 0, db_next_object_ref = 0,
db_starting_species = Nothing,
db_creatures = Map.fromList [], db_creatures = Map.fromList [],
db_player_creature = Nothing,
db_planes = Map.fromList [], db_planes = Map.fromList [],
db_tools = Map.fromList [], db_tools = Map.fromList [],
db_buildings = Map.fromList [], db_buildings = Map.fromList [],
...@@ -232,18 +223,18 @@ setupDBHistory db = ...@@ -232,18 +223,18 @@ setupDBHistory db =
db_here = db, db_here = db,
db_random = rng } db_random = rng }
-- |
-- Returns the DBState of the database.
--
playerState :: (DBReadable m) => m PlayerState playerState :: (DBReadable m) => m PlayerState
playerState = asks db_player_state playerState = asks db_player_state
-- |
-- Sets the DBState of the database.
--
setPlayerState :: PlayerState -> DB () setPlayerState :: PlayerState -> DB ()
setPlayerState state = modify (\db -> db { db_player_state = state }) setPlayerState state = modify (\db -> db { db_player_state = state })
getPlayerCreature :: (DBReadable m) => m (Maybe CreatureRef)
getPlayerCreature = asks db_player_creature
setPlayerCreature :: CreatureRef -> DB ()
setPlayerCreature creature_ref = modify (\db -> db { db_player_creature = Just creature_ref })
dbActionCount :: (DBReadable db) => db Integer dbActionCount :: (DBReadable db) => db Integer
dbActionCount = asks db_action_count dbActionCount = asks db_action_count
...@@ -517,18 +508,6 @@ dbNextTurn refs = ...@@ -517,18 +508,6 @@ dbNextTurn refs =
List.map (\r -> (r,fromMaybe (error "dbNextTurn: missing time coordinate") $ List.map (\r -> (r,fromMaybe (error "dbNextTurn: missing time coordinate") $
Map.lookup (genericReference r) (db_time_coordinates db))) refs) Map.lookup (genericReference r) (db_time_coordinates db))) refs)
-- |
-- Answers the starting species.
--
getStartingSpecies :: DB (Maybe Species)
getStartingSpecies = do gets db_starting_species
-- |
-- Sets the starting species.
--
setStartingSpecies :: Species -> DB ()
setStartingSpecies the_species = modify (\db -> db { db_starting_species = Just the_species })
-- | -- |
-- Takes a snapshot of a SnapshotEvent in progress. -- Takes a snapshot of a SnapshotEvent in progress.
-- --
......
module Roguestar.Lib.DBErrorFlag module Roguestar.Lib.DBErrorFlag
(ErrorFlag(..)) (DBError(..),
ErrorFlag(..))
where where
import Control.Monad.Error
data DBError =
DBError String
| DBErrorFlag ErrorFlag
deriving (Read,Show)
instance Error DBError where
strMsg = DBError
data ErrorFlag = data ErrorFlag =
BuildingApproachWrongAngle -- some buildings (like stargates) are sensitive to the angle of approach BuildingApproachWrongAngle -- some buildings (like stargates) are sensitive to the angle of approach
| NothingAtFeet -- tried to pick something up, but there is nothing at your feet | NothingAtFeet -- tried to pick something up, but there is nothing at your feet
......
{-# LANGUAGE ExistentialQuantification, Rank2Types, FlexibleContexts, ScopedTypeVariables #-} {-# LANGUAGE ExistentialQuantification, Rank2Types, FlexibleContexts, ScopedTypeVariables #-}
-- | -- | The Perception monad is a wrapper for roguestar's core
-- Perception is essentially a catalogue of information that can be -- monad that reveals only as much information as a character
-- observed from a creatures-eye-view, i.e. information that -- legitimately has. Thus, it is suitable for writing AI
-- is legal for a human agent or ai agent to have while choosing -- routines as well as an API for the player's client.
-- it's next move.
--
module Roguestar.Lib.Perception module Roguestar.Lib.Perception
(DBPerception, (DBPerception,
whoAmI, whoAmI,
runPerception, runPerception,
visibleObjects, visibleObjects,
visibleTerrain,
myFaction, myFaction,
Roguestar.Lib.Perception.getCreatureFaction, Roguestar.Lib.Perception.getCreatureFaction,
whereAmI, whereAmI,
...@@ -68,12 +67,16 @@ whoAmI = DBPerception $ ask ...@@ -68,12 +67,16 @@ whoAmI = DBPerception $ ask
-- | -- |
-- Run a DBPerception from the point-of-view of the given creature. -- Run a DBPerception from the point-of-view of the given creature.
-- Note that if you pass any 'Reference' or 'Location' into the perception monad,
-- it will be able to cheat. Therefore, don't.
-- --
runPerception :: (DBReadable db) => CreatureRef -> (forall m. DBReadable m => DBPerception m a) -> db a runPerception :: (DBReadable db) => CreatureRef -> (forall m. DBReadable m => DBPerception m a) -> db a
runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref runPerception creature_ref perception = dbSimulate $ runReaderT (fromPerception perception) creature_ref
visibleTerrain :: (DBReadable db) => DBPerception db [(TerrainPatch,Position)]
visibleTerrain =
do plane_ref <- whatPlaneAmIOn
faction <- myFaction
liftDB $ dbGetVisibleTerrainForFaction faction plane_ref
visibleObjects :: (DBReadable db) => (forall m. DBReadable m => Reference () -> DBPerception m Bool) -> DBPerception db [Location] visibleObjects :: (DBReadable db) => (forall m. DBReadable m => Reference () -> DBPerception m Bool) -> DBPerception db [Location]
visibleObjects filterF = visibleObjects filterF =
do me <- whoAmI do me <- whoAmI
...@@ -108,7 +111,6 @@ localBiome = ...@@ -108,7 +111,6 @@ localBiome =
do plane_ref <- whatPlaneAmIOn do plane_ref <- whatPlaneAmIOn
liftDB $ liftM plane_biome $ dbGetPlane plane_ref liftDB $ liftM plane_biome $ dbGetPlane plane_ref
-- Let's look into re-writing this with A*: -- Let's look into re-writing this with A*:
-- http://hackage.haskell.org/packages/archive/astar/0.2.1/doc/html/Data-Graph-AStar.html -- http://hackage.haskell.org/packages/archive/astar/0.2.1/doc/html/Data-Graph-AStar.html
compass :: (DBReadable db) => DBPerception db Facing compass :: (DBReadable db) => DBPerception db Facing
......
...@@ -4,7 +4,7 @@ module Roguestar.Lib.Plane ...@@ -4,7 +4,7 @@ module Roguestar.Lib.Plane
planetName, planetName,
randomPlanetName, randomPlanetName,
planeDepth, planeDepth,
dbGetCurrentPlane, getCurrentPlane,
Roguestar.Lib.Plane.distanceBetweenSquared, Roguestar.Lib.Plane.distanceBetweenSquared,
pickRandomClearSite_withTimeout, pickRandomClearSite_withTimeout,
pickRandomClearSite, pickRandomClearSite,
...@@ -120,9 +120,9 @@ distanceBetweenSquared a_ref b_ref = ...@@ -120,9 +120,9 @@ distanceBetweenSquared a_ref b_ref =
-- | -- |
-- Gets the current plane of interest based on whose turn it is. -- Gets the current plane of interest based on whose turn it is.
-- --
dbGetCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef) getCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef)
dbGetCurrentPlane = runMaybeT $ getCurrentPlane = runMaybeT $
do creature_with_current_turn <- MaybeT $ liftM creatureOf playerState do creature_with_current_turn <- MaybeT $ liftM subjectOf playerState
(Parent plane_ref) <- liftM detail $ lift $ getPlanarLocation creature_with_current_turn (Parent plane_ref) <- liftM detail $ lift $ getPlanarLocation creature_with_current_turn
return plane_ref return plane_ref
......
module Roguestar.Lib.PlayerState module Roguestar.Lib.PlayerState
(PlayerState(..), (PlayerState(..),
CreatureTurnMode(..),
SnapshotEvent(..), SnapshotEvent(..),
creatureOf, HasSubject(..))
subjectOf,
menuIndex,
modifyMenuIndex)
where where
import Roguestar.Lib.DBData import Roguestar.Lib.DBData
...@@ -15,27 +11,12 @@ import Roguestar.Lib.MakeData ...@@ -15,27 +11,12 @@ import Roguestar.Lib.MakeData
import Roguestar.Lib.TravelData import Roguestar.Lib.TravelData
data PlayerState = data PlayerState =
SpeciesSelectionState SpeciesSelectionState (Maybe Creature)
| ClassSelectionState Creature | PlayerCreatureTurn CreatureRef
| PlayerCreatureTurn CreatureRef CreatureTurnMode
| SnapshotEvent SnapshotEvent | SnapshotEvent SnapshotEvent
| GameOver | GameOver
deriving (Read,Show) deriving (Read,Show)
data CreatureTurnMode =
NormalMode
| MoveMode
| PickupMode Integer
| DropMode Integer
| WieldMode Integer
| MakeMode Integer PrepareMake
| AttackMode
| FireMode
| JumpMode
| TurnMode
| ClearTerrainMode
deriving (Read,Show)
data SnapshotEvent = data SnapshotEvent =
AttackEvent { AttackEvent {
attack_event_source_creature :: CreatureRef, attack_event_source_creature :: CreatureRef,
...@@ -76,44 +57,27 @@ data SnapshotEvent = ...@@ -76,44 +57,27 @@ data SnapshotEvent =
bump_event_new_class :: Maybe CharacterClass } bump_event_new_class :: Maybe CharacterClass }
deriving (Read,Show) deriving (Read,Show)
-- | Get the 'Creature' acting in the given 'PlayerState'. class HasSubject a where
creatureOf :: PlayerState -> Maybe CreatureRef subjectOf :: a -> Maybe CreatureRef
creatureOf state = case state of
PlayerCreatureTurn creature_ref _ -> Just creature_ref
SnapshotEvent event -> subjectOf event
GameOver -> Nothing
ClassSelectionState {} -> Nothing
SpeciesSelectionState {} -> Nothing
-- | Get the subject creature of a 'SnapshotEvent', that is, the creature taking action.
subjectOf :: SnapshotEvent -> Maybe CreatureRef
subjectOf event = case event of
AttackEvent { attack_event_source_creature = attacker_ref } -> Just attacker_ref
MissEvent { miss_event_creature = attacker_ref } -> Just attacker_ref
WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref } -> Just attacker_ref
WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref } -> Just attacker_ref
KilledEvent killed_ref -> Just killed_ref
DisarmEvent { disarm_event_source_creature = attacker_ref } -> Just attacker_ref
SunderEvent { sunder_event_source_creature = attacker_ref } -> Just attacker_ref
TeleportEvent { teleport_event_creature = creature_ref } -> Just creature_ref
HealEvent { heal_event_creature = creature_ref } -> Just creature_ref
ClimbEvent { climb_event_creature = creature_ref } -> Just creature_ref
BumpEvent { bump_event_creature = creature_ref } -> Just creature_ref
ExpendToolEvent {} -> Nothing
-- | Current index into the menu, if there is one.
menuIndex :: PlayerState -> Maybe Integer
menuIndex state = fst $ modifyMenuIndex_ id state
-- | Modify the current index into the menu, if there is one (otherwise has no effect). instance HasSubject PlayerState where
modifyMenuIndex :: (Integer -> Integer) -> PlayerState -> PlayerState subjectOf (SpeciesSelectionState {}) = Nothing
modifyMenuIndex f state = snd $ modifyMenuIndex_ f state subjectOf (PlayerCreatureTurn x) = Just x
subjectOf (SnapshotEvent x) = subjectOf x
subjectOf GameOver = Nothing
modifyMenuIndex_ :: (Integer -> Integer) -> PlayerState -> (Maybe Integer,PlayerState) instance HasSubject SnapshotEvent where
modifyMenuIndex_ f state = case state of subjectOf event = case event of
PlayerCreatureTurn c (PickupMode n) -> (Just n,PlayerCreatureTurn c $ PickupMode $ f n) AttackEvent { attack_event_source_creature = attacker_ref } -> Just attacker_ref
PlayerCreatureTurn c (DropMode n) -> (Just n,PlayerCreatureTurn c $ DropMode $ f n) MissEvent { miss_event_creature = attacker_ref } -> Just attacker_ref
PlayerCreatureTurn c (WieldMode n) -> (Just n,PlayerCreatureTurn c $ WieldMode $ f n) WeaponOverheatsEvent { weapon_overheats_event_creature = attacker_ref } -> Just attacker_ref
PlayerCreatureTurn c (MakeMode n make_prep) -> (Just n,PlayerCreatureTurn c $ MakeMode (f n) make_prep) WeaponExplodesEvent { weapon_explodes_event_creature = attacker_ref } -> Just attacker_ref
x -> (Nothing,x) KilledEvent killed_ref -> Just killed_ref
DisarmEvent { disarm_event_source_creature = attacker_ref } -> Just attacker_ref
SunderEvent { sunder_event_source_creature = attacker_ref } -> Just attacker_ref
TeleportEvent { teleport_event_creature = creature_ref } -> Just creature_ref
HealEvent { heal_event_creature = creature_ref } -> Just creature_ref
ClimbEvent { climb_event_creature = creature_ref } -> Just creature_ref
BumpEvent { bump_event_creature = creature_ref } -> Just creature_ref
ExpendToolEvent {} -> Nothing
{-# LANGUAGE Rank2Types #-}
module Roguestar.Lib.Roguestar module Roguestar.Lib.Roguestar
(Game, (Game,
newGame, newGame,
getPlayerState, getPlayerState,
Roguestar.Lib.Roguestar.getStartingSpecies) rerollStartingSpecies,
Creature(..),
TerrainPatch(..),
Position(..),
Facing(..),
Roguestar.Lib.Roguestar.beginGame,
perceive)
where where
import Roguestar.Lib.DB as DB import Roguestar.Lib.DB as DB
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad
import Roguestar.Lib.PlayerState import Roguestar.Lib.PlayerState
import Roguestar.Lib.SpeciesData import Roguestar.Lib.SpeciesData
import Roguestar.Lib.Random import Roguestar.Lib.Random
import Roguestar.Lib.Creature import Roguestar.Lib.Creature
import Roguestar.Lib.CreatureData
import Roguestar.Lib.BeginGame as BeginGame
import Roguestar.Lib.Perception
import Roguestar.Lib.TerrainData
import Roguestar.Lib.Facing
data Game = Game { data Game = Game {
game_db :: TVar DB_BaseType } game_db :: TVar DB_BaseType }
...@@ -41,12 +55,17 @@ poke g f = ...@@ -41,12 +55,17 @@ poke g f =
getPlayerState :: Game -> IO (Either DBError PlayerState) getPlayerState :: Game -> IO (Either DBError PlayerState)
getPlayerState g = peek g playerState getPlayerState g = peek g playerState
getStartingSpecies :: Game -> IO (Either DBError (Maybe Species)) rerollStartingSpecies :: Game -> IO (Either DBError Species)
getStartingSpecies g = peek g DB.getStartingSpecies rerollStartingSpecies g = poke g $
rerollStartingSpecies :: Game -> Species -> IO (Either DBError Species)
rerollStartingSpecies g species = poke g $
do species <- pickM all_species do species <- pickM all_species
generateInitialPlayerCreature species generateInitialPlayerCreature species
return 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
runPerception player_creature f
...@@ -37,7 +37,7 @@ dbPerformPlayerTurn beh creature_ref = ...@@ -37,7 +37,7 @@ dbPerformPlayerTurn beh creature_ref =
dbFinishPendingAITurns :: DB () dbFinishPendingAITurns :: DB ()
dbFinishPendingAITurns = dbFinishPendingAITurns =
do m_current_plane <- dbGetCurrentPlane do m_current_plane <- getCurrentPlane
case m_current_plane of case m_current_plane of
Just p -> dbFinishPlanarAITurns p Just p -> dbFinishPlanarAITurns p
Nothing -> return () Nothing -> return ()
...@@ -62,7 +62,7 @@ dbFinishPlanarAITurns plane_ref = ...@@ -62,7 +62,7 @@ dbFinishPlanarAITurns plane_ref =
if (faction /= Player) if (faction /= Player)
then do dbPerform1CreatureAITurn creature_ref then do dbPerform1CreatureAITurn creature_ref
dbFinishPlanarAITurns plane_ref dbFinishPlanarAITurns plane_ref
else setPlayerState (PlayerCreatureTurn creature_ref NormalMode) else setPlayerState (PlayerCreatureTurn creature_ref)
return () return ()
_ -> error "dbFinishPlanarAITurns: impossible case" _ -> error "dbFinishPlanarAITurns: impossible case"
......
{-# LANGUAGE TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-}
import Prelude import Prelude
import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T import qualified Data.Text as T
import qualified Text.XHtmlCombinators.Escape as XH import qualified Text.XHtmlCombinators.Escape as XH
import qualified Text.XmlHtml as X
import Control.Exception (SomeException) import Control.Exception (SomeException)
import qualified Control.Monad.CatchIO as CatchIO import qualified Control.Monad.CatchIO as CatchIO
import Control.Monad.Trans import Control.Monad.Trans
import Control.Monad.State
import Control.Applicative import Control.Applicative
import Control.Monad.ST
import Data.STRef
import Data.Array.ST
import Data.Array.IArray
import Data.Array.Unboxed
import Snap.Core import Snap.Core
import Snap.Snaplet import Snap.Snaplet
import Snap.Snaplet.Heist import Snap.Snaplet.Heist
...@@ -16,7 +23,11 @@ import Snap.Http.Server.Config ...@@ -16,7 +23,11 @@ import Snap.Http.Server.Config
import Data.Lens.Template import Data.Lens.Template
import Data.Maybe import Data.Maybe
import Data.Ord import Data.Ord
import qualified Data.List as List
import Roguestar.Lib.Roguestar import Roguestar.Lib.Roguestar
import Roguestar.Lib.PlayerState
import Roguestar.Lib.DBErrorFlag
import Roguestar.Lib.Perception
data App = App { data App = App {
_heist :: Snaplet (Heist App), _heist :: Snaplet (Heist App),
...@@ -62,8 +73,115 @@ static :: Handler App App () ...@@ -62,8 +73,115 @@ static :: Handler App App ()
static = serveDirectory "./static/" static = serveDirectory "./static/"
play :: Handler App App () play :: Handler App App ()
play = ifTop $ play =
do writeBS "hello, world!" 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)]
routeRoguestar :: PlayerState -> [(BS.ByteString,PlayerState -> Handler App App ())] -> Handler App App ()
routeRoguestar ps xs = route $ map (\(bs,f) -> (bs,f ps)) xs
displayCurrentState :: PlayerState -> Handler App App ()
displayCurrentState (SpeciesSelectionState Nothing) =
render "/hidden/play/empty-game"
displayCurrentState (SpeciesSelectionState (Just creature)) =
renderWithSplices "/hidden/play/character-creation"
[("content",return $ [X.TextNode $ T.pack $ "You are a " ++ show (creature_species creature) ++ "."])]
displayCurrentState (PlayerCreatureTurn creature_ref) =
do map_text <- createMap
renderWithSplices "/hidden/play/normal-play"
[("map",return $ [X.Element "pre" [] [X.TextNode map_text]])]
displayCurrentState _ = pass
reroll :: PlayerState -> Handler App App ()
reroll (SpeciesSelectionState _) =
do g <- getGame
liftIO $ rerollStartingSpecies g
replay
reroll _ = pass
accept :: PlayerState -> Handler App App ()
accept (SpeciesSelectionState (Just _)) =