Permalink
Browse files

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

  • Loading branch information...
1 parent 66565b4 commit 155ef0388264adc30fa4be897b0c266b3f9e60ac @clanehin committed Oct 20, 2012
@@ -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
@@ -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
@@ -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
@@ -3,4 +3,4 @@ module Roguestar.Lib.TravelData
(ClimbDirection(..)) where
data ClimbDirection = ClimbUp | ClimbDown
- deriving (Read,Show)
+ deriving (Read,Show,Eq)
@@ -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,14 +21,26 @@ runTests =
unit_tests :: [UnitTest]
unit_tests = [testSessionAliveBeforeTimeout,
- testSessionExpiredAfterTimeout]
+ testSessionExpiredAfterTimeout,
+ testSetPlayerState]
assert :: Bool -> T.Text -> UnitTest
assert ok test_name =
do let message = test_name `T.append` (if ok then ": ok." else ": FAILED.") `T.append` "\n"
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"
@@ -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 ()
@@ -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
@@ -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;
-}
+}

0 comments on commit 155ef03

Please sign in to comment.