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

parent 66565b4d
......@@ -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 }
\ No newline at end of file
creature_max_health = creatureAbilityScore ToughnessTrait c }
......@@ -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,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"
......@@ -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>
......
......@@ -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;
}
\ No newline at end of file
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment