module Game.LambdaHack.State
(
State(..), TgtMode(..), Cursor(..), Status(..)
, slevel, stime
, defaultState
, updateCursor, updateTime, updateDiscoveries, updateLevel, updateDungeon
, Diary(..), defaultDiary
, DebugMode(..), cycleMarkVision, toggleOmniscient
) where
import qualified Data.Set as S
import Data.Binary
import qualified Game.LambdaHack.Config as Config
import qualified System.Random as R
import System.Time
import Game.LambdaHack.Actor
import Game.LambdaHack.Point
import Game.LambdaHack.Level
import qualified Game.LambdaHack.Dungeon as Dungeon
import Game.LambdaHack.Item
import Game.LambdaHack.Msg
import Game.LambdaHack.FOV
import Game.LambdaHack.Time
import qualified Game.LambdaHack.Kind as Kind
import Game.LambdaHack.Content.FactionKind
data Diary = Diary
{ sreport :: Report
, shistory :: History
}
data State = State
{ splayer :: ActorId
, scursor :: Cursor
, sflavour :: FlavourMap
, sdisco :: Discoveries
, sdungeon :: Dungeon.Dungeon
, slid :: Dungeon.LevelId
, scounter :: Int
, srandom :: R.StdGen
, sconfig :: Config.CP
, stakeTime :: Maybe Bool
, squit :: Maybe (Bool, Status)
, sfaction :: Kind.Id FactionKind
, sdebug :: DebugMode
}
deriving Show
data TgtMode =
TgtOff
| TgtExplicit
| TgtAuto
deriving (Show, Eq)
data Cursor = Cursor
{ ctargeting :: TgtMode
, clocLn :: Dungeon.LevelId
, clocation :: Point
, creturnLn :: Dungeon.LevelId
, ceps :: Int
}
deriving Show
data Status =
Killed !Dungeon.LevelId
| Camping
| Victor
| Restart
deriving (Show, Eq, Ord)
data DebugMode = DebugMode
{ smarkVision :: Maybe FovMode
, somniscient :: Bool
}
deriving Show
slevel :: State -> Level
slevel State{slid, sdungeon} = sdungeon Dungeon.! slid
stime :: State -> Time
stime State{slid, sdungeon} = ltime $ sdungeon Dungeon.! slid
defaultDiary :: IO Diary
defaultDiary = do
dateTime <- getClockTime
let curDate = calendarTimeToString $ toUTCTime dateTime
return Diary
{ sreport = emptyReport
, shistory = singletonHistory $ singletonReport $
"Player diary started on " ++ curDate ++ "."
}
defaultState :: Config.CP -> Kind.Id FactionKind -> FlavourMap
-> Dungeon.Dungeon -> Dungeon.LevelId -> Point -> R.StdGen
-> State
defaultState config sfaction flavour dng lid ploc g =
State
0
(Cursor TgtOff lid ploc lid 0)
flavour
S.empty
dng
lid
0
g
config
Nothing
Nothing
sfaction
defaultDebugMode
defaultDebugMode :: DebugMode
defaultDebugMode = DebugMode
{ smarkVision = Nothing
, somniscient = False
}
updateCursor :: (Cursor -> Cursor) -> State -> State
updateCursor f s = s { scursor = f (scursor s) }
updateTime :: (Time -> Time) -> State -> State
updateTime f s = updateLevel (\ lvl@Level{ltime} -> lvl {ltime = f ltime}) s
updateDiscoveries :: (Discoveries -> Discoveries) -> State -> State
updateDiscoveries f s = s { sdisco = f (sdisco s) }
updateLevel :: (Level -> Level) -> State -> State
updateLevel f s = updateDungeon (Dungeon.adjust f (slid s)) s
updateDungeon :: (Dungeon.Dungeon -> Dungeon.Dungeon) -> State -> State
updateDungeon f s = s {sdungeon = f (sdungeon s)}
cycleMarkVision :: State -> State
cycleMarkVision s@State{sdebug = sdebug@DebugMode{smarkVision}} =
s {sdebug = sdebug {smarkVision = case smarkVision of
Nothing -> Just (Digital 100)
Just (Digital _) -> Just Permissive
Just Permissive -> Just Shadow
Just Shadow -> Just Blind
Just Blind -> Nothing }}
toggleOmniscient :: State -> State
toggleOmniscient s@State{sdebug = sdebug@DebugMode{somniscient}} =
s {sdebug = sdebug {somniscient = not somniscient}}
instance Binary Diary where
put Diary{..} = do
put sreport
put shistory
get = do
sreport <- get
shistory <- get
return Diary{..}
instance Binary State where
put (State player cursor flav disco dng lid ct
g config stakeTime _ sfaction _) = do
put player
put cursor
put flav
put disco
put dng
put lid
put ct
put (show g)
put config
put stakeTime
put sfaction
get = do
player <- get
cursor <- get
flav <- get
disco <- get
dng <- get
lid <- get
ct <- get
g <- get
config <- get
stakeTime <- get
sfaction <- get
return
(State player cursor flav disco dng lid ct (read g) config stakeTime
Nothing sfaction defaultDebugMode)
instance Binary TgtMode where
put TgtOff = putWord8 0
put TgtExplicit = putWord8 1
put TgtAuto = putWord8 2
get = do
tag <- getWord8
case tag of
0 -> return TgtOff
1 -> return TgtExplicit
2 -> return TgtAuto
_ -> fail "no parse (TgtMode)"
instance Binary Cursor where
put (Cursor act cln loc rln eps) = do
put act
put cln
put loc
put rln
put eps
get = do
act <- get
cln <- get
loc <- get
rln <- get
eps <- get
return (Cursor act cln loc rln eps)
instance Binary Status where
put (Killed ln) = putWord8 0 >> put ln
put Camping = putWord8 1
put Victor = putWord8 2
put Restart = putWord8 3
get = do
tag <- getWord8
case tag of
0 -> fmap Killed get
1 -> return Camping
2 -> return Victor
3 -> return Restart
_ -> fail "no parse (Status)"