Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Renders a map on the server.

  • Loading branch information...
commit a563fc26182c13d66d2f836474dcb5610ee909b3 1 parent 0cb22b5
@clanehin authored
View
40 Roguestar/Lib/BeginGame.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
module Roguestar.Lib.BeginGame
- (dbBeginGame)
+ (beginGame)
where
import Roguestar.Lib.Plane
@@ -13,6 +13,7 @@ import Roguestar.Lib.Facing
import Roguestar.Lib.TerrainData
import Roguestar.Lib.ToolData
import Control.Monad
+import Control.Monad.Error
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.Substances as Substances
import Roguestar.Lib.PlayerState
@@ -36,20 +37,6 @@ homeBiome Recreant = TundraBiome
homeBiome Reptilian = ForestBiome
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 Anachronid = [sphere Radon]
startingEquipmentBySpecies Ascendant = [sphere Neon]
@@ -69,21 +56,24 @@ dbCreateStartingPlane :: Creature -> DB PlaneRef
dbCreateStartingPlane creature =
do dbNewPlane "belhaven" (TerrainGenerationData {
tg_smootheness = 3,
- tg_biome = homeBiome $ creature_species creature,
- tg_placements = [] }) TheUniverse
+ tg_biome = homeBiome $ creature_species creature,
+ tg_placements = [] }) TheUniverse
-- |
--- Begins the game with the specified starting player creature and the specified starting character class.
--- The character class should not be pre-applied to the creature.
+-- Begins the game with the specified starting player creature.
--
-dbBeginGame :: Creature -> CharacterClass -> DB ()
-dbBeginGame creature character_class =
- do let first_level_creature = applyCharacterClass character_class creature
+beginGame :: DB ()
+beginGame =
+ 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
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]
- 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_ [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),
@@ -92,5 +82,5 @@ dbBeginGame creature character_class =
(_,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 CyborgRegion) =<< generatePlanetInfo cyborg_planets
- setPlayerState $ PlayerCreatureTurn creature_ref NormalMode
+ setPlayerState $ PlayerCreatureTurn creature_ref
View
7 Roguestar/Lib/Creature.hs
@@ -42,13 +42,12 @@ generateCreature :: Faction -> Species -> DB Creature
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
--- database's DBClassSelectionState.
+-- During DBRaceSelectionState, generates a new Creature for the player character.
--
generateInitialPlayerCreature :: Species -> DB ()
generateInitialPlayerCreature 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.
@@ -95,7 +94,7 @@ getTerrainAffinity creature_ref =
-- | Get the current creature, if it belongs to the specified faction, based on the current playerState.
getCurrentCreature :: (DBReadable db) => Faction -> db (Maybe CreatureRef)
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
return $ if is_one_of_us then m_who else Nothing
View
45 Roguestar/Lib/DB.hs
@@ -13,8 +13,9 @@ module Roguestar.Lib.DB
DBReadable(..),
playerState,
setPlayerState,
+ getPlayerCreature,
+ setPlayerCreature,
SnapshotEvent(..),
- DBError(..),
initial_db,
DB_BaseType(db_error_flag),
dbActionCount,
@@ -37,8 +38,6 @@ module Roguestar.Lib.DB
whereIs,
getContents,
move,
- setStartingSpecies,
- getStartingSpecies,
ro, atomic,
logDB,
mapRO, filterRO, sortByRO,
@@ -89,8 +88,8 @@ data DB_History = DB_History {
data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
db_next_object_ref :: Integer,
- db_starting_species :: Maybe Species,
db_creatures :: Map CreatureRef Creature,
+ db_player_creature :: Maybe CreatureRef,
db_planes :: Map PlaneRef Plane,
db_tools :: Map ToolRef Tool,
db_buildings :: Map BuildingRef Building,
@@ -101,14 +100,6 @@ data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
db_action_count :: Integer }
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)
data DB a = DB { cycleDB :: forall r. DB_History -> (a -> DB_History -> DBResult r) -> DBResult r }
@@ -120,7 +111,7 @@ runDB dbAction database =
instance Monad DB where
return a = DB $ \h f -> f a h
k >>= m = DB $ \h f -> cycleDB k h $ \a h' -> cycleDB (m a) h' f
- fail = error
+ fail = throwError . DBError
instance Functor DB where
fmap = liftM
@@ -212,10 +203,10 @@ atomic action ro_action =
--
initial_db :: DB_BaseType
initial_db = DB_BaseType {
- db_player_state = SpeciesSelectionState,
+ db_player_state = SpeciesSelectionState Nothing,
db_next_object_ref = 0,
- db_starting_species = Nothing,
db_creatures = Map.fromList [],
+ db_player_creature = Nothing,
db_planes = Map.fromList [],
db_tools = Map.fromList [],
db_buildings = Map.fromList [],
@@ -232,18 +223,18 @@ setupDBHistory db =
db_here = db,
db_random = rng }
--- |
--- Returns the DBState of the database.
---
playerState :: (DBReadable m) => m PlayerState
playerState = asks db_player_state
--- |
--- Sets the DBState of the database.
---
setPlayerState :: PlayerState -> DB ()
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 = asks db_action_count
@@ -518,18 +509,6 @@ dbNextTurn 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.
--
dbPushSnapshot :: SnapshotEvent -> DB ()
View
13 Roguestar/Lib/DBErrorFlag.hs
@@ -1,7 +1,18 @@
module Roguestar.Lib.DBErrorFlag
- (ErrorFlag(..))
+ (DBError(..),
+ ErrorFlag(..))
where
+import Control.Monad.Error
+
+data DBError =
+ DBError String
+ | DBErrorFlag ErrorFlag
+ deriving (Read,Show)
+
+instance Error DBError where
+ strMsg = DBError
+
data ErrorFlag =
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
View
20 Roguestar/Lib/Perception.hs
@@ -1,16 +1,15 @@
{-# LANGUAGE ExistentialQuantification, Rank2Types, FlexibleContexts, ScopedTypeVariables #-}
--- |
--- Perception is essentially a catalogue of information that can be
--- observed from a creatures-eye-view, i.e. information that
--- is legal for a human agent or ai agent to have while choosing
--- it's next move.
---
+-- | 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.
module Roguestar.Lib.Perception
(DBPerception,
whoAmI,
runPerception,
visibleObjects,
+ visibleTerrain,
myFaction,
Roguestar.Lib.Perception.getCreatureFaction,
whereAmI,
@@ -68,12 +67,16 @@ whoAmI = DBPerception $ ask
-- |
-- 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 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 filterF =
do me <- whoAmI
@@ -108,7 +111,6 @@ localBiome =
do plane_ref <- whatPlaneAmIOn
liftDB $ liftM plane_biome $ dbGetPlane plane_ref
-
-- 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
compass :: (DBReadable db) => DBPerception db Facing
View
8 Roguestar/Lib/Plane.hs
@@ -4,7 +4,7 @@ module Roguestar.Lib.Plane
planetName,
randomPlanetName,
planeDepth,
- dbGetCurrentPlane,
+ getCurrentPlane,
Roguestar.Lib.Plane.distanceBetweenSquared,
pickRandomClearSite_withTimeout,
pickRandomClearSite,
@@ -120,9 +120,9 @@ distanceBetweenSquared a_ref b_ref =
-- |
-- Gets the current plane of interest based on whose turn it is.
--
-dbGetCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef)
-dbGetCurrentPlane = runMaybeT $
- do creature_with_current_turn <- MaybeT $ liftM creatureOf playerState
+getCurrentPlane :: (DBReadable db) => db (Maybe PlaneRef)
+getCurrentPlane = runMaybeT $
+ do creature_with_current_turn <- MaybeT $ liftM subjectOf playerState
(Parent plane_ref) <- liftM detail $ lift $ getPlanarLocation creature_with_current_turn
return plane_ref
View
84 Roguestar/Lib/PlayerState.hs
@@ -1,11 +1,7 @@
module Roguestar.Lib.PlayerState
(PlayerState(..),
- CreatureTurnMode(..),
SnapshotEvent(..),
- creatureOf,
- subjectOf,
- menuIndex,
- modifyMenuIndex)
+ HasSubject(..))
where
import Roguestar.Lib.DBData
@@ -15,27 +11,12 @@ import Roguestar.Lib.MakeData
import Roguestar.Lib.TravelData
data PlayerState =
- SpeciesSelectionState
- | ClassSelectionState Creature
- | PlayerCreatureTurn CreatureRef CreatureTurnMode
+ SpeciesSelectionState (Maybe Creature)
+ | PlayerCreatureTurn CreatureRef
| SnapshotEvent SnapshotEvent
| GameOver
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 =
AttackEvent {
attack_event_source_creature :: CreatureRef,
@@ -76,44 +57,27 @@ data SnapshotEvent =
bump_event_new_class :: Maybe CharacterClass }
deriving (Read,Show)
--- | Get the 'Creature' acting in the given 'PlayerState'.
-creatureOf :: PlayerState -> 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
+class HasSubject a where
+ subjectOf :: a -> Maybe CreatureRef
--- | Modify the current index into the menu, if there is one (otherwise has no effect).
-modifyMenuIndex :: (Integer -> Integer) -> PlayerState -> PlayerState
-modifyMenuIndex f state = snd $ modifyMenuIndex_ f state
+instance HasSubject PlayerState where
+ subjectOf (SpeciesSelectionState {}) = Nothing
+ subjectOf (PlayerCreatureTurn x) = Just x
+ subjectOf (SnapshotEvent x) = subjectOf x
+ subjectOf GameOver = Nothing
-modifyMenuIndex_ :: (Integer -> Integer) -> PlayerState -> (Maybe Integer,PlayerState)
-modifyMenuIndex_ f state = case state of
- PlayerCreatureTurn c (PickupMode n) -> (Just n,PlayerCreatureTurn c $ PickupMode $ f n)
- PlayerCreatureTurn c (DropMode n) -> (Just n,PlayerCreatureTurn c $ DropMode $ f n)
- PlayerCreatureTurn c (WieldMode n) -> (Just n,PlayerCreatureTurn c $ WieldMode $ f n)
- PlayerCreatureTurn c (MakeMode n make_prep) -> (Just n,PlayerCreatureTurn c $ MakeMode (f n) make_prep)
- x -> (Nothing,x)
+instance HasSubject SnapshotEvent where
+ 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
View
31 Roguestar/Lib/Roguestar.hs
@@ -1,16 +1,30 @@
+{-# LANGUAGE Rank2Types #-}
+
module Roguestar.Lib.Roguestar
(Game,
newGame,
getPlayerState,
- Roguestar.Lib.Roguestar.getStartingSpecies)
+ rerollStartingSpecies,
+ Creature(..),
+ TerrainPatch(..),
+ Position(..),
+ Facing(..),
+ Roguestar.Lib.Roguestar.beginGame,
+ perceive)
where
import Roguestar.Lib.DB as DB
import Control.Concurrent.STM
+import Control.Monad
import Roguestar.Lib.PlayerState
import Roguestar.Lib.SpeciesData
import Roguestar.Lib.Random
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 {
game_db :: TVar DB_BaseType }
@@ -41,12 +55,17 @@ poke g f =
getPlayerState :: Game -> IO (Either DBError PlayerState)
getPlayerState g = peek g playerState
-getStartingSpecies :: Game -> IO (Either DBError (Maybe Species))
-getStartingSpecies g = peek g DB.getStartingSpecies
-
-rerollStartingSpecies :: Game -> Species -> IO (Either DBError Species)
-rerollStartingSpecies g species = poke g $
+rerollStartingSpecies :: Game -> IO (Either DBError Species)
+rerollStartingSpecies g = poke g $
do species <- pickM all_species
generateInitialPlayerCreature species
return species
+beginGame :: Game -> IO (Either DBError ())
+beginGame g = poke g $ BeginGame.beginGame
+
+perceive :: Game -> (forall m. DBReadable m => DBPerception m a) -> IO (Either DBError a)
+perceive g f = peek g $
+ do player_creature <- maybe (fail "No player creature selected yet.") return =<< getPlayerCreature
+ runPerception player_creature f
+
View
4 Roguestar/Lib/Turns.hs
@@ -37,7 +37,7 @@ dbPerformPlayerTurn beh creature_ref =
dbFinishPendingAITurns :: DB ()
dbFinishPendingAITurns =
- do m_current_plane <- dbGetCurrentPlane
+ do m_current_plane <- getCurrentPlane
case m_current_plane of
Just p -> dbFinishPlanarAITurns p
Nothing -> return ()
@@ -62,7 +62,7 @@ dbFinishPlanarAITurns plane_ref =
if (faction /= Player)
then do dbPerform1CreatureAITurn creature_ref
dbFinishPlanarAITurns plane_ref
- else setPlayerState (PlayerCreatureTurn creature_ref NormalMode)
+ else setPlayerState (PlayerCreatureTurn creature_ref)
return ()
_ -> error "dbFinishPlanarAITurns: impossible case"
View
124 Roguestar/Server/Main.hs
@@ -1,13 +1,20 @@
{-# LANGUAGE TemplateHaskell, OverloadedStrings, ScopedTypeVariables #-}
import Prelude
-import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as T
import qualified Text.XHtmlCombinators.Escape as XH
+import qualified Text.XmlHtml as X
import Control.Exception (SomeException)
import qualified Control.Monad.CatchIO as CatchIO
import Control.Monad.Trans
+import Control.Monad.State
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.Snaplet
import Snap.Snaplet.Heist
@@ -16,7 +23,11 @@ import Snap.Http.Server.Config
import Data.Lens.Template
import Data.Maybe
import Data.Ord
+import qualified Data.List as List
import Roguestar.Lib.Roguestar
+import Roguestar.Lib.PlayerState
+import Roguestar.Lib.DBErrorFlag
+import Roguestar.Lib.Perception
data App = App {
_heist :: Snaplet (Heist App),
@@ -62,8 +73,115 @@ static :: Handler App App ()
static = serveDirectory "./static/"
play :: Handler App App ()
-play = ifTop $
- do writeBS "hello, world!"
+play =
+ 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 _)) =
+ do g <- getGame
+ liftIO $ beginGame g
+ replay
+accept _ = pass
+
+replay :: Handler App App ()
+replay = redirect "/play"
+
+oops :: DBError -> Handler App App ()
+oops db_error = writeBS $ "FIXME: this error message is useless."
+
+getGame :: Handler App App Game
+getGame = gets _app_game
+
+data MapData = MapData {
+ md_visible_terrain :: [(TerrainPatch,Position)],
+ md_position_info :: (Facing,Position) }
+
+createMap :: Handler App App T.Text
+createMap =
+ do let (x,y) = (21,21) --we'll probably want to let the player customize this later
+ g <- getGame
+ map_data <- liftIO $ perceive g $
+ do visible_terrain <- visibleTerrain
+ visible_objects <- visibleObjects
+ my_position <- whereAmI
+ return $ MapData visible_terrain my_position
+ case map_data of
+ Right map_data_ -> return $ constructMapText (x,y) map_data_
+
+constructMapText :: (Integer,Integer) -> MapData -> T.Text
+constructMapText (width,height) _ | width `mod` 2 == 0 || height `mod` 2 == 0 = error "Map widths and heights must be odd numbers"
+constructMapText (width,height) (MapData visible_terrain (_,Position (center_x,center_y))) = T.unfoldr f (False,0)
+ where f :: (Bool,Int) -> Maybe (Char, (Bool,Int))
+ f (False,i) = if i > snd (bounds char_array)
+ then Nothing
+ else Just (char_array ! i,(succ i `mod` fromInteger width == 0,succ i))
+ f (True,i) = Just ('\n',(False,i))
+ x_adjust = center_x - (width-1) `div` 2
+ y_adjust = center_y - (height-1) `div` 2
+ array_length = fromInteger $ width*height
+ char_array :: UArray Int Char
+ char_array = runSTUArray $
+ do ax <- newArray (0,array_length-1) ' '
+ forM_ visible_terrain $ \(tp,Position (x,y)) ->
+ do let i = fromInteger $ (x-x_adjust) + (y-y_adjust)*width
+ when (i >= 0 && i < array_length-1) $
+ writeArray ax (fromInteger $ (x - x_adjust)+(y - y_adjust)*width) $ charcodeOf tp
+ return ax
+
+class Charcoded a where
+ charcodeOf :: a -> Char
+
+instance Charcoded TerrainPatch where
+ -- eventually I'd want this to look like:
+ -- charcodeOf Grass = ('.', Green, "grass")
+ charcodeOf RockFace = '#'
+ charcodeOf Rubble = '~'
+ charcodeOf Ore = '~'
+ charcodeOf RockyGround = '.'
+ charcodeOf Dirt = '.'
+ charcodeOf Grass = '.'
+ charcodeOf Sand = '~'
+ charcodeOf Desert = '~'
+ charcodeOf Forest = 'f'
+ charcodeOf DeepForest = 'f'
+ charcodeOf Water = '~'
+ charcodeOf DeepWater = '~'
+ charcodeOf Ice = '.'
+ charcodeOf Lava = '~'
+ charcodeOf Glass = '.'
+ charcodeOf RecreantFactory = '_'
+ charcodeOf Upstairs = '>'
+ charcodeOf Downstairs = '<'
main :: IO ()
main = serveSnaplet defaultConfig appInit
View
7 roguestar.cabal
@@ -19,6 +19,7 @@ executable roguestar-server
snap-core >=0.8,
snap-server >= 0.8,
text >=0.11,
+ xmlhtml,
xhtml-combinators == 0.2.2,
MonadCatchIO-transformers >= 0.2 && < 0.3,
data-lens-template,
@@ -46,7 +47,9 @@ library
array >=0.3.0.0,
containers >=0.3.0.0,
base >=4
- exposed-modules:Roguestar.Lib.Roguestar
+ exposed-modules:Roguestar.Lib.Roguestar,
+ Roguestar.Lib.PlayerState,
+ Roguestar.Lib.DBErrorFlag
other-modules: Roguestar.Lib.TravelData,
Roguestar.Lib.VisibilityData,
Roguestar.Lib.FactionData,
@@ -87,9 +90,7 @@ library
Roguestar.Lib.BuildingData,
Roguestar.Lib.Town,
Roguestar.Lib.Random,
- Roguestar.Lib.PlayerState,
Roguestar.Lib.MakeData,
- Roguestar.Lib.DBErrorFlag,
Roguestar.Lib.Behavior.Construction,
Roguestar.Lib.Behavior.Make,
Roguestar.Lib.Activate,
View
12 snaplets/heist/templates/hidden/play/character-creation.tpl
@@ -0,0 +1,12 @@
+<apply template="/hidden/play/context">
+<content/>
+
+<form action="/play/reroll" method="post">
+<input type="submit" name="Regenerate"/>
+</form>
+
+<form action="/play/accept" method="post">
+<input type="submit" name="Accept"/>
+</form>
+
+</apply>
View
3  snaplets/heist/templates/hidden/play/context.tpl
@@ -0,0 +1,3 @@
+<apply template="/hidden/context">
+<content/>
+</apply>
View
7 snaplets/heist/templates/hidden/play/empty-game.tpl
@@ -0,0 +1,7 @@
+<apply template="/hidden/play/context">
+You may randomly re-generate you character as many times as you wish:
+
+<form action="/play/reroll" method="post">
+<input type="submit" name="Generate"/>
+</form>
+</apply>
View
3  snaplets/heist/templates/hidden/play/normal-play.tpl
@@ -0,0 +1,3 @@
+<apply template="/hidden/play/context">
+<map/>
+</apply>
Please sign in to comment.
Something went wrong with that request. Please try again.