Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Refactor to use STRefs for database state and random number generator.

  • Loading branch information...
commit 155ef0388264adc30fa4be897b0c266b3f9e60ac 1 parent 66565b4
@clanehin authored
View
4 Roguestar/Lib/CreatureData.hs
@@ -29,7 +29,7 @@ data Creature = Creature { creature_traits :: Map.Map CreatureTrait Integer,
creature_damage :: Integer,
creature_faction :: Faction,
creature_points :: Integer }
- deriving (Read,Show)
+ deriving (Read,Show,Eq)
-- | Creature having no attributes and undefined 'creature_species', 'creature_random_id', and 'creature_faction'
--
@@ -139,4 +139,4 @@ creatureHealth c = case () of
creature_health = creature_absolute_health result % creature_max_health result,
creature_absolute_health = creature_max_health result - creature_absolute_damage result,
creature_absolute_damage = creature_damage c,
- creature_max_health = creatureAbilityScore ToughnessTrait c }
+ creature_max_health = creatureAbilityScore ToughnessTrait c }
View
70 Roguestar/Lib/DB.hs
@@ -7,8 +7,7 @@
TypeFamilies #-}
module Roguestar.Lib.DB
- (DBResult,
- DB,
+ (DB,
runDB,
DBReadable(..),
playerState,
@@ -82,10 +81,11 @@ import Control.Parallel.Strategies
import System.IO.Unsafe
import Roguestar.Lib.Logging
import Control.Monad.ST
+import Data.STRef
-data DB_History = DB_History {
- db_here :: DB_BaseType,
- db_random :: RNG }
+data DBContext s = DBContext {
+ db_info :: STRef s DB_BaseType,
+ db_rng :: STRef s RNG }
data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
db_next_object_ref :: Integer,
@@ -101,24 +101,27 @@ data DB_BaseType = DB_BaseType { db_player_state :: PlayerState,
db_action_count :: Integer }
deriving (Read,Show)
-type DBResult r = Either DBError (r,DB_History)
-data DB a = DB { internalRunDB :: forall s. DB_History -> ST s (DBResult a) }
+data DB a = DB { internalRunDB :: forall s. DBContext s -> ST s (Either DBError a) }
runDB :: DB a -> DB_BaseType -> IO (Either DBError (a,DB_BaseType))
runDB dbAction database =
- do hist <- setupDBHistory database
- let result = runST $ internalRunDB dbAction hist
- return $ case result of
- Left err -> Left err
- Right (a,DB_History here _) -> Right (a,here)
+ do rng <- randomIO
+ return $ runST $
+ do data_ref <- newSTRef database
+ rng_ref <- newSTRef rng
+ result <- internalRunDB dbAction (DBContext data_ref rng_ref)
+ database' <- readSTRef data_ref
+ return $ case result of
+ Left err -> Left err
+ Right a -> Right (a,database')
instance Monad DB where
- return a = DB $ \h -> return $ Right (a,h)
- k >>= m = DB $ \h ->
- do result <- internalRunDB k h
+ return a = DB $ const $ return $ Right a
+ k >>= m = DB $ \context ->
+ do result <- internalRunDB k context
case result of
Left err -> return $ Left err
- Right (a,h') -> internalRunDB (m a) h'
+ Right a -> internalRunDB (m a) context
fail s = DB $ \_ -> return $ Left $ DBError s
instance Functor DB where
@@ -129,18 +132,21 @@ instance Applicative DB where
(<*>) = ap
instance MonadState DB_BaseType DB where
- get = DB $ \h -> return $ Right (db_here h,h)
- put s = DB $ \h -> return $ Right ((),modification h)
- where modification = \db -> db { db_here = s { db_action_count = succ $ db_action_count $ db_here db } }
+ get = DB $ \context -> liftM Right $ readSTRef (db_info context)
+ put db1 = DB $ \context ->
+ do db0 <- readSTRef (db_info context)
+ writeSTRef (db_info context) $
+ db1 { db_action_count = succ $ db_action_count db0 }
+ return $ Right ()
instance MonadReader DB_BaseType DB where
ask = get
local modification actionM =
do split_rng <- dbRandomSplit
- s <- get
+ db <- get
modify modification
a <- catchError (liftM Right actionM) (return . Left)
- DB $ \h -> return $ Right $ ((), h { db_here = s, db_random = split_rng })
+ DB $ \context -> liftM Right $ writeSTRef (db_rng context) split_rng
either throwError return a
instance MonadError DBError DB where
@@ -158,9 +164,11 @@ instance MonadRandom DB where
getRandomRs min_max = liftM (randomRs min_max) $ dbRandom Random.split
dbRandom :: (RNG -> (a,RNG)) -> DB a
-dbRandom rgen = DB $ \h ->
- do let (x,g) = rgen (db_random h)
- return $ Right (x, h { db_random = g })
+dbRandom rgen = DB $ \context ->
+ do g0 <- readSTRef (db_rng context)
+ let (x,g1) = rgen g0
+ writeSTRef (db_rng context) g1
+ return $ Right x
dbRandomSplit :: DB RNG
dbRandomSplit = dbRandom Random.split
@@ -172,14 +180,15 @@ class (Monad db,MonadError DBError db,MonadReader DB_BaseType db,MonadRandom db,
instance DBReadable DB where
dbSimulate = local id
dbPeepSnapshot actionM =
- do s <- DB $ \h -> return $ Right ((db_here h),h)
+ do db <- get
m_snapshot <- gets db_prior_snapshot
case m_snapshot of
Just snapshot ->
do split_rng <- dbRandomSplit
- DB $ \h -> return $ Right ((), h { db_here = snapshot })
+ put snapshot
a <- dbSimulate actionM
- DB $ \h -> return $ Right ((), h { db_here = s, db_random = split_rng })
+ put db
+ DB $ \context -> liftM Right $ writeSTRef (db_rng context) split_rng
return $ Just a
Nothing -> return Nothing
@@ -230,13 +239,6 @@ initial_db = DB_BaseType {
db_prior_snapshot = Nothing,
db_action_count = 0 }
-setupDBHistory :: DB_BaseType -> IO DB_History
-setupDBHistory db =
- do rng <- randomIO
- return $ DB_History {
- db_here = db,
- db_random = rng }
-
playerState :: (DBReadable m) => m PlayerState
playerState = asks db_player_state
View
6 Roguestar/Lib/PlayerState.hs
@@ -16,10 +16,10 @@ data PlayerState =
| PlayerCreatureTurn CreatureRef
| SnapshotEvent SnapshotEvent
| GameOver GameOverReason
- deriving (Read,Show)
+ deriving (Read,Show,Eq)
data GameOverReason = PlayerIsDead | PlayerIsVictorious
- deriving (Read,Show)
+ deriving (Read,Show,Eq)
data SnapshotEvent =
AttackEvent {
@@ -61,7 +61,7 @@ data SnapshotEvent =
bump_event_creature :: CreatureRef,
bump_event_new_level :: Maybe Integer,
bump_event_new_class :: Maybe CharacterClass }
- deriving (Read,Show)
+ deriving (Read,Show,Eq)
class HasSubject a where
subjectOf :: a -> Maybe CreatureRef
View
2  Roguestar/Lib/TravelData.hs
@@ -3,4 +3,4 @@ module Roguestar.Lib.TravelData
(ClimbDirection(..)) where
data ClimbDirection = ClimbUp | ClimbDown
- deriving (Read,Show)
+ deriving (Read,Show,Eq)
View
25 Roguestar/Lib/UnitTests.hs
@@ -9,6 +9,8 @@ import Data.Maybe
import Control.Concurrent
import Data.Monoid
import System.IO
+import Roguestar.Lib.DB
+import Roguestar.Lib.PlayerState
type UnitTest = WriterT (T.Text,All) IO ()
@@ -19,7 +21,8 @@ runTests =
unit_tests :: [UnitTest]
unit_tests = [testSessionAliveBeforeTimeout,
- testSessionExpiredAfterTimeout]
+ testSessionExpiredAfterTimeout,
+ testSetPlayerState]
assert :: Bool -> T.Text -> UnitTest
assert ok test_name =
@@ -27,6 +30,17 @@ assert ok test_name =
tell (message, All ok)
liftIO $ hPutStr stderr $ T.unpack message
+assertEqual :: (Show a,Eq a) => a -> a -> T.Text -> UnitTest
+assertEqual actual expected test_name =
+ do let ok = actual == expected
+ message = test_name `T.append` (if ok then ": ok." else ": FAILED." `T.append` "\n"
+ `T.append`
+ ("Actual: " `T.append` T.pack (show actual) `T.append` "\n")
+ `T.append`
+ ("Expected: " `T.append` T.pack (show expected))) `T.append` "\n"
+ tell (message, All ok)
+ liftIO $ hPutStr stderr $ T.unpack message
+
testSessionAliveBeforeTimeout :: UnitTest
testSessionAliveBeforeTimeout =
do game_state <- liftIO $ createGameState (GameConfiguration 10 0)
@@ -43,3 +57,12 @@ testSessionExpiredAfterTimeout =
liftIO $ threadDelay 100
m_g2 <- liftIO $ retrieveGame game_uuid (GameConfiguration 10 12) game_state
assert ( isNothing m_g2 ) "testSessionExpiredAfterTimeout"
+
+testSetPlayerState :: UnitTest
+testSetPlayerState =
+ do m_pstate <- liftIO $ flip runDB initial_db $
+ do setPlayerState (GameOver PlayerIsVictorious)
+ playerState
+ case m_pstate of
+ Left err -> assert False "testSetPlayerState (failed in monad)"
+ Right (pstate,_) -> assertEqual pstate (GameOver PlayerIsVictorious) "testSetPlayerState"
View
2  Roguestar/Server/Main.hs
@@ -84,7 +84,7 @@ makeGlobals :: IO Aeson.Value
makeGlobals =
do (unit_test_result,unit_tests_passed) <- liftIO runTests
return $ object $ concat $ [
- (if not unit_tests_passed then ["failed_unit_tests" .= object ["text_content" .= String unit_test_result]] else [])
+ (if not unit_tests_passed then ["failed-unit-tests" .= object ["text-content" .= String unit_test_result]] else [])
]
handle500 :: MonadSnap m => m a -> m ()
View
8 static/index.mustache
@@ -2,12 +2,14 @@
<div id="documenttext" class="roguebox">
-{{#failed_unit_tests}}
+{{#server-globals}}{{#failed-unit-tests}}
+<div class="horrible">
<p>One or more unit tests failed:</p>
<pre>
-{{{text_content}}}
+{{{text-content}}}
</pre>
-{{/failed_unit_tests}}
+</div>
+{{/failed-unit-tests}}{{/server-globals}}
<h1>Roguestar</h1>
View
20 static/roguebasic.css
@@ -8,7 +8,7 @@ body {
}
#main {
- width: 1028px;
+ width: 1028px;
margin: auto;
padding: 0;
}
@@ -26,14 +26,14 @@ body {
}
#menu ul {
- overflow: hidden;
+ overflow: hidden;
list-style: none;
margin: 0;
padding: 0;
}
#menu ul li {
- float: left;
+ float: left;
display: inline;
white-space: nowrap;
border-right: ridge;
@@ -55,7 +55,7 @@ body {
}
#menu ul li a:hover {
- text-decoration: none;
+ text-decoration: none;
}
#menu ul li.right {
@@ -74,6 +74,16 @@ body {
padding: 0;
}
+.horrible {
+ padding: 1cm;
+ font-weight: bold;
+ border: solid;
+ border-width: 1cm;
+ border-color: #AA0000;
+ background-color: #000000;
+ color: #FFFFFF;
+}
+
.help {
font-size: 20px;
}
@@ -420,4 +430,4 @@ a:hover {
border: solid;
border-width: 1px;
border-color: #444444;
-}
+}
Please sign in to comment.
Something went wrong with that request. Please try again.