packages feed

LambdaHack 0.2.8 → 0.2.10

raw patch · 108 files changed

+4200/−3043 lines, 108 filesdep +pretty-show

Dependencies added: pretty-show

Files

+ .travis.yml view
@@ -0,0 +1,7 @@+language: haskell++install:+  - cabal install gtk2hs-buildtools+  - cabal install ConfigFile regex-posix regex-compat gtk --enable-tests --reinstall --force-reinstalls --constraint="mtl>=2.1.2" --constraint="containers>=0.5.2.1" --constraint="template-haskell==2.7.0.0" --constraint="text>=0.11.2.3"+  - cabal install --enable-tests --force-reinstalls --constraint="mtl>=2.1.2" --constraint="containers>=0.5.2.1" --constraint="template-haskell==2.7.0.0" --constraint="text>=0.11.2.3"+  - make test-travis
− DumbBot/Main.hs 
@@ -1,22 +0,0 @@-module Main where--import qualified System.Random as R-import System.Environment-import Control.Monad--move :: R.StdGen -> Int -> IO ()-move g k = do-  let (c, ng) = R.randomR ('0', 'z') g-  putChar c-  when (k > 0) $ move ng (k - 1)--main :: IO ()-main = do-  args <- getArgs-  case args of-    [seed, count] -> do-      -- Start by dumping config (hack: ' ', see Std.hs) with the game seed.-      putChar ' '-      -- Note that the seed is separate from the game seed.-      move (R.mkStdGen (read seed)) (read count)-    _ -> error "Two integer arguments required: random seed and iteration count."
Game/LambdaHack/Client.hs view
@@ -5,9 +5,10 @@ module Game.LambdaHack.Client   ( cmdClientAISem, cmdClientUISem   , loopAI, loopUI, exeFrontend-  , MonadClient, MonadClientUI, MonadConnClient+  , MonadClient, MonadClientUI, MonadClientReadServer, MonadClientWriteServer   ) where +import Control.Monad import Data.Maybe  import Game.LambdaHack.Client.Action@@ -15,13 +16,16 @@ import Game.LambdaHack.Client.Binding import Game.LambdaHack.Client.ClientSem import Game.LambdaHack.Client.Config+import Game.LambdaHack.Client.Draw import Game.LambdaHack.Client.LoopAction import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action+import Game.LambdaHack.Common.Animation (DebugModeCli (..)) import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.ClientCmd import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import Game.LambdaHack.Frontend import Game.LambdaHack.Utils.Assert@@ -31,7 +35,7 @@   maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})     $ Nothing   -- TODO: undoAtomic atomic -cmdClientAISem :: (MonadAtomic m, MonadConnClient c m)+cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdSerTakeTime m)                => CmdClientAI -> m () cmdClientAISem cmd = case cmd of   CmdAtomicAI cmdA -> do@@ -41,77 +45,83 @@     mapM_ (storeUndo . CmdAtomic) cmds   CmdQueryAI aid -> do     cmdC <- queryAI aid-    ConnServer{writeConnServer} <- getConn-    writeConnServer cmdC+    writeServer cmdC+  CmdPingAI ->+    writeServer $ WaitSer $ toEnum (-1)  cmdClientUISem :: ( MonadAtomic m, MonadClientAbort m-                  , MonadClientUI m, MonadConnClient c m )+                  , MonadClientUI m, MonadClientWriteServer CmdSer m )                => CmdClientUI -> m ()-cmdClientUISem cmd =-  case cmd of-    CmdAtomicUI cmdA -> do-      cmds <- cmdAtomicFilterCli cmdA-      mapM_ cmdAtomicSemCli cmds-      mapM_ execCmdAtomic cmds-      mapM_ (drawCmdAtomicUI False) cmds-      mapM_ (storeUndo . CmdAtomic) cmds  -- TODO: only store cmdA?-    SfxAtomicUI sfx -> do-      drawSfxAtomicUI False sfx-      storeUndo $ SfxAtomic sfx-    CmdQueryUI aid -> do-      mleader <- getsClient _sleader-      assert (isJust mleader `blame` cmd) skip-      ConnServer{writeConnServer} <- getConn-      cmdH <- queryUI aid-      writeConnServer cmdH--wireSession :: (SessionUI -> State -> StateClient-                -> ConnServer CmdClientUI -> IO ())-            -> (SessionUI -> State -> StateClient-                -> ConnServer CmdClientAI -> IO ())-            -> Kind.COps-            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())-                -> (FactionId -> ChanServer CmdClientAI -> IO ())-                -> IO ())-            -> IO ()-wireSession exeClientUI exeClientAI cops@Kind.COps{corule} exeServer = do-  -- UI config reloaded at each client start.-  sconfigUI <- mkConfigUI corule-  let !sbinding = stdBinding sconfigUI  -- evaluate to check for errors-      font = configFont sconfigUI-  defHist <- defHistory-  let cli = defStateClient defHist sconfigUI-      s = updateCOps (const cops) emptyState-      executorAI fid chanS =-        let noSession = assert `failure` fid-        in exeClientAI noSession s (cli fid True) (connServer chanS)-      executorUI fid fromF chanS =-        let sfconn = connFrontend fid fromF-        in exeClientUI SessionUI{..} s (cli fid False) (connServer chanS)-  startupF font $ exeServer executorUI executorAI+cmdClientUISem cmd = case cmd of+  CmdAtomicUI cmdA -> do+    cmds <- cmdAtomicFilterCli cmdA+    mapM_ cmdAtomicSemCli cmds+    mapM_ execCmdAtomic cmds+    mapM_ (drawCmdAtomicUI False) cmds+    mapM_ (storeUndo . CmdAtomic) cmds  -- TODO: only store cmdA?+  SfxAtomicUI sfx -> do+    drawSfxAtomicUI False sfx+    storeUndo $ SfxAtomic sfx+  CmdQueryUI aid -> do+    mleader <- getsClient _sleader+    assert (isJust mleader `blame` "query without leader" `with` cmd) skip+    cmdH <- queryUI aid+    writeServer cmdH+  CmdPingUI -> do+    -- Hack: in noMore mode, ping the frontend, too.+    snoMore <- getsClient $ snoMore . sdebugCli+    when snoMore $ void $ displayMore ColorFull "Flushing frames."+    -- Return the ping.+    writeServer $ TakeTimeSer $ WaitSer $ toEnum (-1)  -- | Wire together game content, the main loop of game clients, -- the main game loop assigned to this frontend (possibly containing -- the server loop, if the whole game runs in one process), -- UI config and the definitions of game commands. exeFrontend :: ( MonadAtomic m, MonadClientAbort m, MonadClientUI m-               , MonadConnClient CmdClientUI m+               , MonadClientReadServer CmdClientUI m+               , MonadClientWriteServer CmdSer m                , MonadAtomic n-               , MonadConnClient CmdClientAI n )+               , MonadClientReadServer CmdClientAI n+               , MonadClientWriteServer CmdSerTakeTime n )             => (m () -> SessionUI -> State -> StateClient-                -> ConnServer CmdClientUI+                -> ChanServer CmdClientUI CmdSer                 -> IO ())             -> (n () -> SessionUI -> State -> StateClient-                -> ConnServer CmdClientAI+                -> ChanServer CmdClientAI CmdSerTakeTime                 -> IO ())-            -> Kind.COps-            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())-               -> (FactionId -> ChanServer CmdClientAI -> IO ())+            -> Kind.COps -> DebugModeCli+            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer+                 -> IO ())+               -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime+                   -> IO ())                -> IO ())             -> IO ()-exeFrontend executorUI executorAI cops exeServer = do-  let loopClientUI = loopUI cmdClientUISem-      loopClientAI = loopAI cmdClientAISem-      exeClientUI = executorUI loopClientUI-      exeClientAI = executorAI loopClientAI-  wireSession exeClientUI exeClientAI cops exeServer+exeFrontend executorUI executorAI+            cops@Kind.COps{corule} sdebugCli exeServer = do+  -- UI config reloaded at each client start.+  sconfigUI <- mkConfigUI corule+  let !sbinding = stdBinding sconfigUI  -- evaluate to check for errors+      sdebugMode =+        (\dbg -> dbg {sfont =+            sfont dbg `mplus` Just (configFont sconfigUI)}) .+        (\dbg -> dbg {smaxFps =+            smaxFps dbg `mplus` Just (configMaxFps sconfigUI)}) .+        (\dbg -> dbg {snoAnim =+            snoAnim dbg `mplus` Just (configNoAnim sconfigUI)}) .+        (\dbg -> dbg {ssavePrefixCli =+            ssavePrefixCli dbg `mplus` Just (configSavePrefix sconfigUI)})+        $ sdebugCli+  defHist <- defHistory+  let exeClientUI = executorUI $ loopUI sdebugMode cmdClientUISem+      exeClientAI = executorAI $ loopAI sdebugMode cmdClientAISem+      cli = defStateClient defHist sconfigUI+      s = updateCOps (const cops) emptyState+      eClientAI fid =+        let noSession = assert `failure` "AI client needs no UI session"+                               `with` fid+        in exeClientAI noSession s (cli fid True)+      eClientUI fid fromF =+        let sfconn = connFrontend fid fromF+        in exeClientUI SessionUI{..} s (cli fid False)+  startupF sdebugMode $ exeServer eClientUI eClientAI
Game/LambdaHack/Client/Action.hs view
@@ -1,16 +1,14 @@-{-# LANGUAGE OverloadedStrings #-} -- | Game action monads and basic building blocks for human and computer -- player actions. Has no access to the the main action type. -- Does not export the @liftIO@ operation nor a few other implementation -- details. module Game.LambdaHack.Client.Action   ( -- * Action monads-    MonadClient( getClient, getsClient, putClient, modifyClient )+    MonadClient( getClient, getsClient, putClient, modifyClient, saveClient )   , MonadClientUI-  , MonadConnClient( getConn )+  , MonadClientReadServer(..), MonadClientWriteServer(..)   , MonadClientAbort( abortWith, tryWith )   , SessionUI(..), ConnFrontend(..), connFrontend-  , ConnServer(..), connServer     -- * Various ways to abort action   , abort, abortIfWith, neverMind     -- * Abort exception handlers@@ -30,7 +28,7 @@     -- * Draw frames   , drawOverlay, animate     -- * Assorted primitives-  , clientGameSave, restoreGame, displayPush, scoreToSlideshow+  , restoreGame, removeServerSave, displayPush, scoreToSlideshow   , rndToAction, getArenaUI, getLeaderUI   , targetToPos, partAidLeader, partActorLeader   , debugPrint@@ -47,15 +45,13 @@ import qualified Data.Monoid as Monoid import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.IO as T import qualified NLP.Miniutter.English as MU-import System.IO (hFlush, stderr)-import qualified System.Random as R+import System.Directory+import System.FilePath import System.Time  import Game.LambdaHack.Client.Action.ActionClass import Game.LambdaHack.Client.Action.ConfigIO-import qualified Game.LambdaHack.Client.Action.Save as Save import Game.LambdaHack.Client.Binding import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.Draw@@ -64,7 +60,6 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.ClientCmd import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore import qualified Game.LambdaHack.Common.Key as K@@ -74,19 +69,17 @@ import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random+import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Frontend as Frontend import Game.LambdaHack.Utils.Assert  debugPrint :: MonadClient m => Text -> m () debugPrint t = do-  debug <- getsClient sdebugCli-  when debug $ liftIO $ do-    delay <- R.randomRIO (0, 1000000)-    threadDelay delay  -- try not to interleave letters with other clients-    T.hPutStrLn stderr t-    hFlush stderr+  sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli+  when sdbgMsgCli $ liftIO $ Save.delayPrint t  connFrontend :: FactionId -> Frontend.ChanFrontend -> ConnFrontend connFrontend fid fromF = ConnFrontend@@ -97,12 +90,6 @@       liftIO $ atomically $ writeTQueue toF (fid, efr)   } -connServer :: ChanServer c -> ConnServer c-connServer ChanServer{..} = ConnServer-  { readConnServer =  liftIO . atomically . readTQueue $ fromServer-  , writeConnServer = liftIO . atomically . writeTQueue toServer-  }- -- | Reset the state and resume from the last backup point, i.e., invoke -- the failure continuation. abort :: MonadClientAbort m => m a@@ -127,7 +114,8 @@ tryIgnore :: MonadClientAbort m => m () -> m () tryIgnore =   tryWith (\msg -> unless (T.null msg)-                   $ assert `failure` msg <+> "in tryIgnore")+                   $ assert `failure` "can't catch failure with message"+                            `with` msg)  -- | Set the current exception handler. Apart of executing it, -- draw and pass along a slide with the abort message (even if message empty).@@ -157,10 +145,11 @@   readConnFrontend  -- | Display a slideshow, awaiting confirmation for each slide except the last.-getInitConfirms :: MonadClientUI m => [K.KM] -> Slideshow -> m Bool-getInitConfirms frontClear slides = do+getInitConfirms :: MonadClientUI m+                => ColorMode -> [K.KM] -> Slideshow -> m Bool+getInitConfirms dm frontClear slides = do   ConnFrontend{..} <- getsSession sfconn-  frontSlides <- mapM (drawOverlay ColorFull) $ runSlideshow slides+  frontSlides <- mapM (drawOverlay dm) $ runSlideshow slides   -- The first two cases are optimizations:   case frontSlides of     [] -> return True@@ -170,13 +159,13 @@     _ -> do       writeConnFrontend Frontend.FrontSlides{..}       km <- readConnFrontend-      return $! km /= K.KM {key=K.Esc, modifier=K.NoModifier}+      return $! km /= K.escKey  getLeaderUI :: MonadClientUI m => m ActorId getLeaderUI = do   cli <- getClient   case _sleader cli of-    Nothing -> assert `failure` cli+    Nothing -> assert `failure` "leader expected but not found" `with` cli     Just leader -> return leader  getArenaUI :: MonadClientUI m => m LevelId@@ -185,10 +174,18 @@   case mleader of     Just leader -> getsState $ blid . getActorBody leader     Nothing -> do-      dungeon <- getsState sdungeon-      case EM.minViewWithKey dungeon of-        Just ((s, _), _) -> return s-        Nothing -> assert `failure` dungeon+      side <- getsClient sside+      factionD <- getsState sfactionD+      let fact = factionD EM.! side+      case gquit fact of+        Just Status{stDepth} -> return $ toEnum stDepth+        Nothing -> do+          dungeon <- getsState sdungeon+          let (minD, maxD) =+                case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of+                  (Just ((s, _), _), Just ((e, _), _)) -> (s, e)+                  _ -> assert `failure` "empty dungeon" `with` dungeon+          return $ max minD $ min maxD $ playerEntry $ gplayer fact  -- | Calculate the position of leader's target. targetToPos :: MonadClientUI m => m (Maybe Point)@@ -236,7 +233,9 @@ getPerFid :: MonadClient m => LevelId -> m Perception getPerFid lid = do   fper <- getsClient sfper-  return $! fromMaybe (assert `failure` lid) $ EM.lookup lid fper+  return $! fromMaybe (assert `failure` "no perception at given level"+                              `with` (lid, fper))+                      $ EM.lookup lid fper  -- | Display an overlay and wait for a human player command. getKeyOverlayCommand :: MonadClientUI m => Overlay -> m K.KM@@ -248,9 +247,6 @@   km <- promptGetKey [] frame   return $! fromMaybe km $ M.lookup km $ kmacro keyb -getConfirm :: MonadClientUI m => [K.KM] -> SingleFrame -> m Bool-getConfirm = Frontend.getConfirmGeneric promptGetKey- -- | Push frames or delays to the frame queue. displayFrames :: MonadClientUI m => Frames -> m () displayFrames = mapM_ (displayFrame False)@@ -260,7 +256,7 @@ getYesNo frame = do   let keys = [ K.KM {key=K.Char 'y', modifier=K.NoModifier}              , K.KM {key=K.Char 'n', modifier=K.NoModifier}-             , K.KM {key=K.Esc, modifier=K.NoModifier}+             , K.escKey              ]   K.KM {key} <- promptGetKey keys frame   case key of@@ -271,9 +267,9 @@ -- tried to cancel/escape. displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool displayMore dm prompt = do-  sli <- promptToSlideshow $ prompt <+> moreMsg-  frame <- drawOverlay dm $ head $ runSlideshow sli-  getConfirm [] frame+  slides <- promptToSlideshow $ prompt <+> moreMsg+  -- Two frames drawn total (unless 'prompt' very long).+  getInitConfirms dm [] $ slides Monoid.<> toSlideshow [[]]  -- | Print a yes/no question and return the player's answer. Use black -- and white colours to turn player's attention to the choice.@@ -293,7 +289,7 @@   slides <- fmap runSlideshow $ overlayToSlideshow (prompt <> ", ESC]") ov   let legalKeys =         [ K.KM {key=K.Space, modifier=K.NoModifier}-        , K.KM {key=K.Esc, modifier=K.NoModifier} ]+        , K.escKey ]         ++ keys       loop [] = neverMind True       loop (x : xs) = do@@ -317,7 +313,7 @@ overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow overlayToSlideshow prompt overlay = do   lid <- getArenaUI-  lysize <- getsLevel lid lysize  -- TODO: screen length or viewLevel+  Level{lysize} <- getLevel lid  -- TODO: screen length or viewLevel   sreport <- getsClient sreport   let msg = splitReport (addMsg sreport prompt)   return $! splitOverlay lysize msg overlay@@ -356,34 +352,30 @@   return $! maybe Monoid.mempty showScore             $ HighScore.register table total time status date -saveName :: FactionId -> Bool -> String-saveName side isAI =-  let n = fromEnum side-  in (if n > 0-      then "human_" ++ show n-      else "computer_" ++ show (-n))-     ++ if isAI then ".ai.sav" else ".ui.sav"--clientGameSave :: MonadClient m => Bool -> m ()-clientGameSave toBkp = do-  s <- getState-  cli <- getClient-  configUI <- getsClient sconfigUI-  side <- getsClient sside-  isAI <- getsClient sisAI-  liftIO $ Save.saveGameCli (saveName side isAI) toBkp configUI s cli--restoreGame :: MonadClient m => m (Either (State, StateClient, Msg) Msg)+restoreGame :: MonadClient m => m (Maybe (State, StateClient)) restoreGame = do   Kind.COps{corule} <- getsState scops-  configUI <- getsClient sconfigUI   let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule-      title = rtitle $ Kind.stdRuleset corule   side <- getsClient sside   isAI <- getsClient sisAI-  let sName = saveName side isAI-  liftIO $ Save.restoreGameCli sName configUI pathsDataFile title+  prefix <- getsClient $ ssavePrefixCli . sdebugCli+  ConfigUI{ configAppDataDir+          , configUICfgFile } <- getsClient sconfigUI+  let copies = [(configUICfgFile <.> ".default", configUICfgFile <.> ".ini")]+      name = fromMaybe "save" prefix <.> saveName side isAI+  liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile +-- | Assuming the client runs on the same machine and for the same+-- user as the server, move the server savegame out of the way.+removeServerSave :: MonadClient m => m ()+removeServerSave = do+  prefix <- getsClient $ ssavePrefixCli . sdebugCli  -- hack: assume the same+  ConfigUI{configAppDataDir} <- getsClient sconfigUI+  let serverSaveFile = configAppDataDir+                       </> fromMaybe "save" prefix+                       <.> serverSaveName+  liftIO $ renameFile serverSaveFile (serverSaveFile ++ ".bkp")+ -- | Invoke pseudo-random computation with the generator kept in the state. rndToAction :: MonadClient m => Rnd a -> m a rndToAction r = do@@ -400,24 +392,26 @@   cops <- getsState scops   sreport <- getsClient sreport   mleader <- getsClient _sleader-  Level{lxsize, lysize} <- getsLevel arena id+  Level{lxsize, lysize} <- getLevel arena   cli <- getClient   s <- getState   per <- getPerFid arena   let over = renderReport sreport       topLineOnly = truncateMsg lxsize over       basicFrame = draw ColorFull cops per arena mleader cli s [topLineOnly]-  return $ renderAnim lxsize lysize basicFrame anim+  snoAnim <- getsClient $ snoAnim . sdebugCli+  return $ if fromMaybe False snoAnim+           then [Just basicFrame]+           else renderAnim lxsize lysize basicFrame anim  -- | The part of speech describing the actor or a special name if a leader -- of the observer's faction. The actor may not be present in the dungeon. partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part partActorLeader aid b = do-  Kind.COps{coactor} <- getsState scops   mleader <- getsClient _sleader   return $! case mleader of     Just leader | aid == leader -> "you"-    _ -> partActor coactor b+    _ -> partActor b  -- | The part of speech describing the actor (designated by actor id -- and present in the dungeon) or a special name if a leader
Game/LambdaHack/Client/Action/ActionClass.hs view
@@ -11,8 +11,8 @@ import Game.LambdaHack.Client.Binding import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action+import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Frontend (FrontReq)  -- | The information that is constant across a client playing session,@@ -32,11 +32,6 @@       -- ^ write a UI request to the frontend   } -data ConnServer c = ConnServer-  { readConnServer  :: MonadConnClient c m => m c-  , writeConnServer :: MonadConnClient c m => CmdSer -> m ()-  }- class MonadActionRO m => MonadClient m where   getClient    :: m StateClient   getsClient   :: (StateClient -> a) -> m a@@ -45,6 +40,7 @@   -- We do not provide a MonadIO instance, so that outside of Action/   -- nobody can subvert the action monads by invoking arbitrary IO.   liftIO       :: IO a -> m a+  saveClient   :: m ()  instance (Monoid a, MonadClient m) => MonadClient (WriterT a m) where   getClient    = lift getClient@@ -52,6 +48,7 @@   modifyClient = lift . modifyClient   putClient    = lift . putClient   liftIO       = lift . liftIO+  saveClient   = lift saveClient  class MonadClient m => MonadClientUI m where   getsSession  :: (SessionUI -> a) -> m a@@ -59,9 +56,12 @@ instance (Monoid a, MonadClientUI m) => MonadClientUI (WriterT a m) where   getsSession  = lift . getsSession -class MonadClient m => MonadConnClient c m | m -> c where-  getConn  :: m (ConnServer c)+class MonadClient m => MonadClientReadServer c m | m -> c where+  readServer  :: m c +class MonadClient m => MonadClientWriteServer d m | m -> d where+  writeServer  :: d -> m ()+ -- | The bottom of the action monads class semilattice. class MonadClient m => MonadClientAbort m where   -- Set the current exception handler. First argument is the handler,@@ -73,3 +73,11 @@ instance (Monoid a, MonadClientAbort m) => MonadClientAbort (WriterT a m) where   tryWith exc m = WriterT $ tryWith (runWriterT . exc) (runWriterT m)   abortWith = lift . abortWith++saveName :: FactionId -> Bool -> String+saveName side isAI =+  let n = fromEnum side  -- we depend on the numbering hack to number saves+  in (if n > 0+      then "human_" ++ show n+      else "computer_" ++ show (-n))+     ++ if isAI then ".ai.sav" else ".ui.sav"
Game/LambdaHack/Client/Action/ActionType.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -- | The main game action monad type implementation. Just as any other -- component of the library, this implementation can be substituted. -- This module should not be imported anywhere except in 'Action'@@ -7,20 +7,28 @@   ( FunActionCli, ActionCli, executorCli   ) where +import Control.Concurrent.STM import qualified Data.EnumMap.Strict as EM+import Data.Maybe import qualified Data.Text as T+import System.FilePath import qualified System.Random as R  import Game.LambdaHack.Client.Action.ActionClass+import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action+import Game.LambdaHack.Common.Animation+import Game.LambdaHack.Common.ClientCmd import Game.LambdaHack.Common.Msg+import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State  -- | The type of the function inside any client action.-type FunActionCli c a =+type FunActionCli c d a =    SessionUI                          -- ^ client UI setup data-   -> ConnServer c                          -- ^ this client connection information+   -> (ChanServer c d, Save.ChanSave (State, StateClient))+                                      -- ^ this client connection information    -> (State -> StateClient -> a -> IO ())                                       -- ^ continuation    -> (R.StdGen -> Msg -> IO ())      -- ^ failure/reset continuation@@ -29,35 +37,32 @@    -> IO ()  -- | Client parts of actions of human and computer player characters.-newtype ActionCli c a = ActionCli {runActionCli :: FunActionCli c a}+newtype ActionCli c d a = ActionCli {runActionCli :: FunActionCli c d a}  -- | Invokes the action continuation on the provided argument.-returnActionCli :: a -> ActionCli c a+returnActionCli :: a -> ActionCli c d a returnActionCli x = ActionCli (\_c _d k _a s cli -> k s cli x)  -- | Distributes the session and shutdown continuation, -- threads the state and history.-bindActionCli :: ActionCli c a -> (a -> ActionCli c b) -> ActionCli c b+bindActionCli :: ActionCli c d a -> (a -> ActionCli c d b) -> ActionCli c d b bindActionCli m f = ActionCli (\c d k a s cli ->                           let next ns ncli x =                                 runActionCli (f x) c d k a ns ncli                           in runActionCli m c d next a s cli) -instance Monad (ActionCli c) where+instance Monad (ActionCli c d) where   return = returnActionCli   (>>=)  = bindActionCli  -- TODO: make sure fmap is inlined and all else is inlined here and elsewhere-instance Functor (ActionCli c) where+instance Functor (ActionCli c d) where   fmap f m =     ActionCli (\c d k a s cli ->                runActionCli m c d (\s' cli' ->                                  k s' cli' . f) a s cli) -instance Show (ActionCli c a) where-  show _ = "an action"--instance MonadClientAbort (ActionCli c) where+instance MonadClientAbort (ActionCli c d) where   tryWith exc m  =     ActionCli (\c d k a s cli ->              let runA srandom msg =@@ -65,39 +70,58 @@              in runActionCli m c d k runA s cli)   abortWith msg  = ActionCli (\_c _d _k a _s cli -> a (srandom cli) msg) -instance MonadActionRO (ActionCli c) where+instance MonadActionRO (ActionCli c d) where   getState       = ActionCli (\_c _d k _a s cli -> k s cli s)   getsState      = (`fmap` getState) -instance MonadAction (ActionCli c) where+instance MonadAction (ActionCli c d) where   modifyState f  = ActionCli (\_c _d k _a s cli -> k (f s) cli ())   putState       = modifyState . const -instance MonadClient (ActionCli c) where+instance MonadClient (ActionCli c d) where   getClient      = ActionCli (\_c _d k _a s cli -> k s cli cli)   getsClient     = (`fmap` getClient)   modifyClient f = ActionCli (\_c _d k _a s cli -> k s (f cli) ())   putClient      = modifyClient . const   liftIO x       = ActionCli (\_c _d k _a s cli -> x >>= k s cli)+  saveClient     = ActionCli (\_c (_, toSave) k _a s cli -> do+                                 Save.saveToChan toSave (s, cli)+                                 k s cli ()) -instance MonadClientUI (ActionCli c) where+instance MonadClientUI (ActionCli c d) where   getsSession f  = ActionCli (\c _d k _a s cli -> k s cli (f c)) -instance MonadConnClient c (ActionCli c) where-  getConn        = ActionCli (\_c d k _a s cli -> k s cli d)+instance MonadClientReadServer c (ActionCli c d) where+  readServer     =+    ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do+                  ccmd <- atomically . readTQueue $ fromServer+                  k s cli ccmd) --- | Run an action, with a given session, state and history, in the @IO@ monad.-executorCli :: ActionCli c ()-            -> SessionUI -> State -> StateClient -> ConnServer c+instance MonadClientWriteServer d (ActionCli c d) where+  writeServer scmd =+    ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do+                  atomically . writeTQueue toServer $ scmd+                  k s cli ())++-- | Init the client, then run an action, with a given session,+-- state and history, in the @IO@ monad.+executorCli :: ActionCli c d ()+            -> SessionUI -> State -> StateClient -> ChanServer c d             -> IO () executorCli m sess s cli d =-  runActionCli m-    sess-    d-    (\_ _ _ -> return ())-    (\_ msg -> let err = "unhandled abort for client"-                         <+> showT (sfactionD s EM.! sside cli)-                         <+> ":" <+> msg-               in fail $ T.unpack err)-    s-    cli+  let saveFile (_, cli2) =+        configAppDataDir (sconfigUI cli2)+        </> fromMaybe "save" (ssavePrefixCli (sdebugCli cli2))+        <.> saveName (sside cli2) (sisAI cli2)+      exe toSave =+        runActionCli m+          sess+          (d, toSave)+          (\_ _ _ -> return ())+          (\_ msg -> let err = "unhandled abort for client"+                               <+> showT (sfactionD s EM.! sside cli)+                               <+> ":" <+> msg+                     in fail $ T.unpack err)+          s+          cli+  in Save.wrapInSaves saveFile exe
Game/LambdaHack/Client/Action/ConfigIO.hs view
@@ -22,8 +22,8 @@  overrideCP :: CP -> FilePath -> IO CP overrideCP cp@(CP defCF) cfile = do-  b <- doesFileExist cfile-  if not b+  cpExists <- doesFileExist cfile+  if not cpExists     then return cp     else do       c <- CF.readfile defCF cfile@@ -32,11 +32,11 @@ -- | Read a player configuration file and use it to override -- options from a default config. Currently we can't unset options, -- only override. The default config, passed in argument @configDefault@,--- is expected to come from a default configuration file included via CPP.+-- is expected to come from a default configuration file included via TH. -- The player configuration comes from file @cfile@. mkConfig :: String -> FilePath -> IO CP mkConfig configDefault cfile = do-  let delComment = map (drop 2) $ init . drop 3 $ lines configDefault+  let delComment = map (drop 2) $ lines configDefault       unConfig = unlines delComment       -- Evaluate, to catch config errors ASAP.       !defCF = forceEither $ CF.readstring CF.emptyCP unConfig@@ -63,32 +63,27 @@ toCP :: CF.ConfigParser -> CP toCP cf = CP $ cf {CF.optionxform = id} --- | In case of corruption, just fail.-forceEither :: Show a => Either a b -> b-forceEither (Left a)  = assert `failure` a-forceEither (Right b) = b- -- | Simplified access to an option in a given section. -- Fails if the option is not present. get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a get (CP conf) s o =   if CF.has_option conf s o   then forceEither $ CF.get conf s o-  else assert `failure` "Unknown config option: " ++ s ++ "." ++ o+  else assert `failure` "unknown CF option" `with` (s, o, CF.to_string conf)  -- | An association list corresponding to a section. Fails if no such section. getItems :: CP -> CF.SectionSpec -> [(String, String)] getItems (CP conf) s =   if CF.has_section conf s   then forceEither $ CF.items conf s-  else assert `failure` "Unknown config section: " ++ s+  else assert `failure` "unknown CF section" `with` (s, CF.to_string conf)  parseConfigUI :: FilePath -> CP -> ConfigUI parseConfigUI dataDir cp =   let mkKey s =         case K.keyTranslate s of           K.Unknown _ ->-            assert `failure` ("unknown config file key <" ++ s ++ ">")+            assert `failure` "unknown config file key" `with` (s, cp)           key -> key       mkKM ('C':'T':'R':'L':'-':s) = K.KM {key=mkKey s, modifier=K.Control}       mkKM s = K.KM {key=mkKey s, modifier=K.NoModifier}@@ -96,19 +91,22 @@         let mkCommand (key, def) = (mkKM key, read def :: HumanCmd)             section = getItems cp "commands"         in map mkCommand section-      configAppDataDirUI = dataDir+      configAppDataDir = dataDir       configUICfgFile = dataDir </> "config.ui"+      configSavePrefix = get cp "file" "savePrefix"       configMacros =         let trMacro (from, to) =               let fromTr = mkKM from                   toTr  = mkKM to               in if fromTr == toTr-                 then assert `failure` "degenerate alias: " ++ show toTr+                 then assert `failure` "degenerate alias" `with` toTr                  else (fromTr, toTr)             section = getItems cp "macros"         in map trMacro section       configFont = get cp "ui" "font"       configHistoryMax = get cp "ui" "historyMax"+      configMaxFps = get cp "ui" "maxFps"+      configNoAnim = get cp "ui" "noAnim"   in ConfigUI{..}  -- | Read and parse UI config file.
− Game/LambdaHack/Client/Action/Save.hs 
@@ -1,95 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Saving and restoring client game state.-module Game.LambdaHack.Client.Action.Save-  ( saveGameCli, restoreGameCli-  ) where--import Control.Concurrent-import qualified Control.Exception as Ex hiding (handle)-import Control.Monad-import Data.Text (Text)-import qualified Data.Text as T-import System.Directory-import System.FilePath-import System.IO.Unsafe (unsafePerformIO)--import Game.LambdaHack.Client.Config-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.State-import Game.LambdaHack.Utils.File---- TODO: Refactor the client and server Save.hs, after--- https://github.com/kosmikus/LambdaHack/issues/37.--_saveLock :: MVar ()-{-# NOINLINE _saveLock #-}-_saveLock = unsafePerformIO newEmptyMVar---- | Save game to the backup savefile, in case of crashes.--- This is only a backup, so no problem is the game is shut down--- before saving finishes, so we don't wait on the mvar. However,--- if a previous save is already in progress, we skip this save.-saveGameBkpCli :: String -> ConfigUI -> State -> StateClient -> IO ()-saveGameBkpCli saveName ConfigUI{configAppDataDirUI} s cli = do---  b <- tryPutMVar saveLock ()---  when b $---    void $ forkIO $ do-      let saveFile = configAppDataDirUI </> saveName-          saveFileBkp = saveFile <.> ".bkp"-      encodeEOF saveFile (s, cli)-      renameFile saveFile saveFileBkp---      takeMVar saveLock---- | Save a simple serialized version of the current state.--- Protected by a lock to avoid corrupting the file.-saveGameCli :: String -> Bool -> ConfigUI -> State -> StateClient -> IO ()-saveGameCli saveName True configUI s cl =-  saveGameBkpCli saveName configUI s cl-saveGameCli saveName False ConfigUI{configAppDataDirUI} s cli = do---  putMVar saveLock ()-  let saveFile = configAppDataDirUI </> saveName-  encodeEOF saveFile (s, cli)---  takeMVar saveLock---- | Restore a saved game, if it exists. Initialize directory structure,--- if needed.-restoreGameCli :: String -> ConfigUI -> (FilePath -> IO FilePath) -> Text-               -> IO (Either (State, StateClient, Msg) Msg)-restoreGameCli saveName ConfigUI{ configAppDataDirUI-                                , configUICfgFile }-               pathsDataFile title = do-  tryCreateDir configAppDataDirUI-  tryCopyDataFiles pathsDataFile-    [(configUICfgFile <.> ".default", configUICfgFile <.> ".ini")]-  let saveFile = configAppDataDirUI </> saveName-      saveFileBkp = saveFile <.> ".bkp"-  sb <- doesFileExist saveFile-  bb <- doesFileExist saveFileBkp-  when sb $ renameFile saveFile saveFileBkp-  -- If the savefile exists but we get IO or decoding errors, we show them,-  -- back up the savefile, move it out of the way and start a new game.-  -- If the savefile was randomly corrupted or made read-only,-  -- that should solve the problem. Serious IO problems (e.g. failure-  -- to create a user data directory) terminate the program with an exception.-  res <- Ex.try $-    if sb-    then do-      (s, cli) <- strictDecodeEOF saveFileBkp-      let msg = "Welcome back to" <+> title <> "."-      return $ Left (s, cli, msg)-    else-      if bb-      then do-        (s, cli) <- strictDecodeEOF saveFileBkp-        let msg = "No client savefile found."-                  <+> "Restoring from a backup savefile."-        return $ Left (s, cli, msg)-      else do-        let msg = "Welcome to" <+> title <> "!"-        return $ Right msg-  let handler :: Ex.SomeException -> IO (Either (State, StateClient, Msg) Msg)-      handler e = let msg = "Client restore failed. The error message is:"-                            <+> (T.unwords . T.lines) (showT e)-                  in return $ Right msg-  either handler return res
Game/LambdaHack/Client/AtomicSemCli.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Semantics of client UI response to atomic commands. -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.@@ -37,6 +36,7 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Utils.Assert  -- * CmdAtomicAI@@ -47,9 +47,9 @@ cmdAtomicFilterCli :: MonadClient m => CmdAtomic -> m [CmdAtomic] cmdAtomicFilterCli cmd = case cmd of   AlterTileA lid p fromTile toTile -> do-    Kind.COps{cotile = Kind.Ops{oname}} <- getsState scops-    lxsize <- getsLevel lid lxsize-    t <- getsLevel lid (`at` p)+    Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops+    lvl@Level{lxsize} <- getLevel lid+    let t = lvl `at` p     if t == fromTile       then return [cmd]       else do@@ -60,17 +60,18 @@         -- to @toTile@. See @alterTileA@.         let subject = ""  -- a hack, we we don't handle adverbs well             verb = "turn into"-            msg = makeSentence [ "the", MU.Text $ oname t+            msg = makeSentence [ "the", MU.Text $ tname $ okind t                                , "at position", MU.Text $ showPoint lxsize p                                , "suddenly"  -- adverb                                , MU.SubjectVerbSg subject verb-                               , MU.AW $ MU.Text $ oname toTile ]+                               , MU.AW $ MU.Text $ tname $ okind toTile ]         return [ cmd  -- reveal the tile                , MsgAllA msg  -- show the message                ]   SearchTileA aid p fromTile toTile -> do     b <- getsState $ getActorBody aid-    t <- getsLevel (blid b) (`at` p)+    lvl <- getLevel $ blid b+    let t = lvl `at` p     if t == toTile       then -- Already knows the tile fully.            return []@@ -79,8 +80,9 @@                 return [ AlterTileA (blid b) p fromTile toTile  -- reveal tile                        , cmd  -- show the message                        ]-           else -- Misguided. Should never happen, LoseTile resets memory.-                assert `failure` (t, cmd)+           else -- Misguided.+                assert `failure` "LoseTile fails to reset memory"+                       `with` (aid, p, fromTile, toTile, b, t, cmd)   DiscoverA _ _ iid _ -> do     disco <- getsClient sdisco     item <- getsState $ getItemBody iid@@ -117,7 +119,7 @@              else Just $ LoseActorA aid b (getActorItem aid s)         outActor = mapMaybe fActor outPrio     -- Wipe out remembered items on tiles that now came into view.-    lfloor <- getsLevel lid lfloor+    Level{lfloor, lsmell} <- getLevel lid     let inFov = totalVisible perNew ES.\\ totalVisible perOld         pMaybe p = maybe Nothing (\x -> Just (p, x))         inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p lfloor)@@ -127,7 +129,6 @@         inItem = concatMap fBag inFloor     -- Remembered map tiles not wiped out, due to optimization in @spotTileA@.     -- Wipe out remembered smell on tiles that now came into smell Fov.-    lsmell <- getsLevel lid lsmell     let inSmellFov = smellVisible perNew ES.\\ smellVisible perOld         inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p lsmell)                         (ES.elems inSmellFov)@@ -155,13 +156,15 @@ -- kept for each command received. cmdAtomicSemCli :: MonadClient m => CmdAtomic -> m () cmdAtomicSemCli cmd = case cmd of+  DestroyActorA aid _ _ -> destroyActorA aid+  LoseActorA aid _ _ -> destroyActorA aid   LeadFactionA fid source target -> do     side <- getsClient sside     when (side == fid) $ do       mleader <- getsClient _sleader       assert (mleader == source     -- somebody changed the leader for us               || mleader == target  -- we changed the leader originally-              `blame` (cmd, mleader)) skip+              `blame` "unexpected leader" `with` (cmd, mleader)) skip       modifyClient $ \cli -> cli {_sleader = target}   DiscoverA lid p iid ik -> discoverA lid p iid ik   CoverA lid p iid ik -> coverA lid p iid ik@@ -180,10 +183,16 @@                   , sdebugCli}   ResumeA _fid sfper -> modifyClient $ \cli -> cli {sfper}   KillExitA _fid -> killExitA-  SaveExitA -> saveExitA-  SaveBkpA -> clientGameSave True+  SaveBkpA -> saveClient   _ -> return () +-- We wipe out the target, because if the actor gets recreated+-- on another level, the old position does not make sense.+-- And if he is really dead, we avoid a memory leak.+destroyActorA :: MonadClient m => ActorId -> m ()+destroyActorA aid =+  modifyClient $ \cli -> cli {stargetD = EM.delete aid $ stargetD cli}+ perceptionA :: MonadClient m => LevelId -> PerActor -> PerActor -> m () perceptionA lid outPA inPA = do   cops <- getsState scops@@ -217,7 +226,7 @@           , psmell = PerceptionVisible ES.empty }         outPer = paToDummy outPA         inPer = paToDummy inPA-        adj Nothing = assert `failure` lid+        adj Nothing = assert `failure` "no perception to alter" `with` lid         adj (Just per) = Just $ dummyToPer $ addPer (diffPer per outPer) inPer         f = EM.alter adj lid     modifyClient $ \cli -> cli {sfper = f (sfper cli)}@@ -227,25 +236,22 @@ discoverA lid p iid ik = do   item <- getsState $ getItemBody iid   let f Nothing = Just ik-      f (Just ik2) = assert `failure` (lid, p, iid, ik, ik2)+      f (Just ik2) = assert `failure` "already discovered"+                            `with` (lid, p, iid, ik, ik2)   modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}  coverA :: MonadClient m        => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m () coverA lid p iid ik = do   item <- getsState $ getItemBody iid-  let f Nothing = assert `failure` (lid, p, iid, ik)-      f (Just ik2) = assert (ik == ik2 `blame` (ik, ik2)) Nothing+  let f Nothing = assert `failure` "already covered" `with` (lid, p, iid, ik)+      f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"+                                       `with` (ik, ik2)) Nothing   modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}  killExitA :: MonadClient m => m () killExitA = modifyClient $ \cli -> cli {squit = True} -saveExitA :: MonadClient m => m ()-saveExitA = do-  clientGameSave False-  modifyClient $ \cli -> cli {squit = True}- -- * CmdAtomicUI  -- TODO: let user configure which messages are not created, which are@@ -265,21 +271,12 @@   CreateActorA aid body _ -> do     when verbose $ actorVerbMU aid body "appear"     lookAtMove aid-  DestroyActorA aid body _ -> do-    side <- getsClient sside-    if bhp body <= 0 && not (bproj body) && bfid body == side then do-      actorVerbMU aid body "die"-      void $ displayMore ColorBW ""-    else when verbose $ actorVerbMU aid body "disappear"-  CreateItemA _ item k _ | verbose -> itemVerbMU item k "appear"-  DestroyItemA _ item k _ | verbose -> itemVerbMU item k "disappear"-  LoseActorA aid body _ -> do-    side <- getsClient sside-    -- If no other faction actor is looking, death is invisible and-    -- so is domination, time-freeze, etc. Then, this command appears instead.-    when (bfid body == side && bhp body <= 0 && not (bproj body)) $ do-      actorVerbMU aid body "be missing in action"-      void $ displayMore ColorFull ""+  DestroyActorA aid body _ ->+    destroyActorUI aid body "die" "be destroyed" verbose+  CreateItemA _ item k _ -> itemVerbMU item k "drop to the ground"+  DestroyItemA _ item k _ -> itemVerbMU item k "disappear"+  LoseActorA aid body _ ->+    destroyActorUI aid body "be missing in action" "be lost" verbose   MoveActorA aid _ _ -> lookAtMove aid   WaitActorA aid _ _| verbose -> aVerbMU aid "wait"   DisplaceActorA source target -> displaceActorUI source target@@ -293,7 +290,6 @@                   then "speed up"                   else "slow down"   LeadFactionA fid (Just source) (Just target) -> do-    Kind.COps{coactor} <- getsState scops     side <- getsClient sside     when (fid == side) $ do       actorD <- getsState sactorD@@ -301,8 +297,8 @@         Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do           -- Regardless who the leader is, give proper names here, not 'you'.           tb <- getsState $ getActorBody target-          let subject = partActor coactor tb-              object  = partActor coactor sb+          let subject = partActor tb+              object  = partActor sb           msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"                                 , "from", object ]         _ -> skip@@ -318,15 +314,15 @@   AlterTileA{} | verbose ->     return ()  -- TODO: door opens   SearchTileA aid _ fromTile toTile -> do-    Kind.COps{cotile = Kind.Ops{oname}} <- getsState scops+    Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops     subject <- partAidLeader aid     let verb = "reveal that the"-        subject2 = MU.Text $ oname fromTile+        subject2 = MU.Text $ tname $ okind fromTile         verb2 = "be"     let msg = makeSentence [ MU.SubjectVerbSg subject verb                            , MU.SubjectVerbSg subject2 verb2                            , "a hidden"-                           , MU.Text $ oname toTile ]+                           , MU.Text $ tname $ okind toTile ]     msgAdd msg   AgeGameA t -> do     when (t > timeClip) $ displayFrames [Nothing]  -- show delay@@ -390,11 +386,12 @@   actorVerbMU aid b verb  itemVerbMU :: MonadClientUI m => Item -> Int -> MU.Part -> m ()-itemVerbMU item k verb = do+itemVerbMU item k verb = assert (k > 0) $ do   Kind.COps{coitem} <- getsState scops   disco <- getsClient sdisco-  let msg =-        makeSentence [MU.SubjectVerbSg (partItemWs coitem disco k item) verb]+  let subject = partItemWs coitem disco k item+      msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]+          | otherwise = makeSentence [MU.SubjectVerbSg subject verb]   msgAdd msg  _iVerbMU :: MonadClientUI m => ItemId -> Int -> MU.Part -> m ()@@ -412,8 +409,17 @@                          , partItemWs coitem disco k item ]   msgAdd msg +destroyActorUI :: MonadClientUI m+               => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m ()+destroyActorUI aid body verb verboseVerb verbose = do+  side <- getsClient sside+  if (bfid body == side && bhp body <= 0 && not (bproj body)) then do+    actorVerbMU aid body verb+    void $ displayMore ColorBW ""+  else when verbose $ actorVerbMU aid body verboseVerb+ moveItemUI :: MonadClientUI m-          => Bool -> ItemId -> Int -> Container -> Container -> m ()+           => Bool -> ItemId -> Int -> Container -> Container -> m () moveItemUI verbose iid k c1 c2 = do   Kind.COps{coitem} <- getsState scops   item <- getsState $ getItemBody iid@@ -451,7 +457,7 @@ quitFactionUI :: MonadClientUI m               => FactionId -> Maybe Actor -> Maybe Status -> m () quitFactionUI fid mbody toSt = do-  Kind.COps{coitem=Kind.Ops{oname, ouniqGroup}} <- getsState scops+  Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops   factionD <- getsState sfactionD   let fact = factionD EM.! fid       fidName = MU.Text $ gname fact@@ -501,7 +507,7 @@           Just aid -> do             b <- getsState $ getActorBody aid             getsState $ calculateTotal b-      let currencyName = MU.Text $ oname $ ouniqGroup "currency"+      let currencyName = MU.Text $ iname $ okind $ ouniqGroup "currency"           itemMsg = makeSentence [ "Your loot is worth"                                  , MU.CarWs total currencyName ]                     <+> moreMsg@@ -512,11 +518,13 @@         else do           io <- floorItemOverlay bag           overlayToSlideshow itemMsg io+      -- Show score for any UI client, even though it is saved only+      -- for human UI clients.       scoreSlides <- scoreToSlideshow total status       partingSlide <- promptToSlideshow $ pp <+> moreMsg       shutdownSlide <- promptToSlideshow pp       -- TODO: First ESC cancels items display.-      void $ getInitConfirms []+      void $ getInitConfirms ColorFull []         $ startingSlide Monoid.<> itemSlides       -- TODO: Second ESC cancels high score and parting message display.       -- The last slide stays onscreen during shutdown, etc.@@ -531,14 +539,14 @@   RecoilD source target _ _ -> do     spart <- partAidLeader source     tpart <- partAidLeader target-    msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink back from", tpart]+    msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]   ProjectD aid iid -> aiVerbMU aid "aim" iid 1   CatchD aid iid -> aiVerbMU aid "catch" iid 1   ActivateD aid iid -> aiVerbMU aid "activate"{-TODO-} iid 1   CheckD aid iid -> aiVerbMU aid "check" iid 1-  TriggerD aid _p _feat _ | verbose ->+  TriggerD aid _p _feat | verbose ->     aVerbMU aid "trigger"  -- TODO: opens door-  ShunD aid _p _ _ | verbose ->+  ShunD aid _p _ | verbose ->     aVerbMU aid "shun"  -- TODO: shuns stairs down   EffectD aid effect -> do     b <- getsState $ getActorBody aid@@ -593,11 +601,13 @@           let msg = makeSentence                 [MU.CardinalWs nEnemy "howl", "of anger", "can be heard"]           msgAdd msg-        Effect.Dominate ->-          if fid == side then lookAtMove aid+        Effect.Dominate -> do+          if fid == side then do+            aVerbMU aid $ MU.Text "black out, dominated by foes"+            void $ displayMore ColorFull ""           else do             fidName <- getsState $ gname . (EM.! fid) . sfactionD-            aVerbMU aid $ MU.Text $ "fall under the influence of" <+> fidName+            aVerbMU aid $ MU.Text $ "be no longer controlled by" <+> fidName         Effect.ApplyPerfume ->           msgAdd "The fragrance quells all scents in the vicinity."         Effect.Searching{} -> do@@ -606,8 +616,9 @@                 [ "It gets lost and"                 , MU.SubjectVerbSg subject "search in vain" ]           msgAdd msg-        Effect.Ascend{} -> actorVerbMU aid b "find a way upstairs"-        Effect.Descend{} -> actorVerbMU aid b "find a way downstairs"+        Effect.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs"+        Effect.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs"+        Effect.Ascend{} -> assert `failure` sfx         _ -> return ()   MsgFidD _ msg -> msgAdd msg   MsgAllD msg -> msgAdd msg@@ -619,6 +630,7 @@     -- of last shown     displayPush   DisplayDelayD _ -> displayFrames [Nothing]+  RecordHistoryD _ -> recordHistory   _ -> return ()  strikeD :: MonadClientUI m
Game/LambdaHack/Client/Binding.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Generic binding of keys to commands, procesing macros, -- printing command help. No operation in this module -- involves the 'State' or 'Action' type.@@ -22,12 +21,12 @@  -- | Bindings and other information about human player commands. data Binding = Binding-  { kcmd    :: M.Map K.KM (Text, Bool, HumanCmd)-                                    -- ^ binding keys to commands-  , kmacro  :: M.Map K.KM K.KM      -- ^ macro map-  , kmajor  :: [K.KM]               -- ^ major commands-  , kminor  :: [K.KM]               -- ^ minor commands-  , krevMap :: M.Map HumanCmd K.KM  -- ^ from cmds to their main keys+  { kcmd    :: !(M.Map K.KM (Text, Bool, HumanCmd))+                                       -- ^ binding keys to commands+  , kmacro  :: !(M.Map K.KM K.KM)      -- ^ macro map+  , kmajor  :: ![K.KM]                 -- ^ major commands+  , kminor  :: ![K.KM]                 -- ^ minor commands+  , krevMap :: !(M.Map HumanCmd K.KM)  -- ^ from cmds to their main keys   }  -- | Binding of keys to movement and other standard commands,
Game/LambdaHack/Client/ClientSem.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Semantics of most 'CmdClientAI' client commands. module Game.LambdaHack.Client.ClientSem where @@ -11,6 +10,7 @@  import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.Binding+import Game.LambdaHack.Client.Draw import Game.LambdaHack.Client.HumanCmd import Game.LambdaHack.Client.HumanLocal import Game.LambdaHack.Client.HumanSem@@ -23,63 +23,105 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Key as K import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.StrategyKind+import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.Frequency -queryAI :: MonadClient m => ActorId -> m CmdSer+queryAI :: MonadClient m => ActorId -> m CmdSerTakeTime queryAI oldAid = do-  Kind.COps{costrat=Kind.Ops{okind}} <- getsState scops+  Kind.COps{cofact=Kind.Ops{okind}, corule} <- getsState scops   side <- getsClient sside   fact <- getsState $ \s -> sfactionD s EM.! side-  let aiMember = fmap okind $ gAiMember fact+  let abilityLeader = fAbilityLeader $ okind $ gkind fact+      abilityOther = fAbilityOther $ okind $ gkind fact   mleader <- getsClient _sleader   if -- Keep the leader: only a leader is allowed to pick another leader.      mleader /= Just oldAid-     -- Keep the leader: AIs are the same.-     || gAiLeader fact == gAiMember fact+     -- Keep the leader: abilities are the same (we assume leader can do+     -- at least as much as others).+     || abilityLeader == abilityOther      -- Keep the leader: other members can't melee.-     || Ability.Melee `notElem` maybe [] sabilities aiMember+     || Ability.Melee `notElem` abilityOther     then queryAIPick oldAid     else do       fper <- getsClient sfper-      visFoes <- visibleFoes fper oldAid       oldBody <- getsState $ getActorBody oldAid+      oldAis <- getsState $ getActorItem oldAid       btarget <- getsClient $ getTarget oldAid       let arena = blid oldBody+      -- Visibility ignored --- every foe is visible by somebody.+      foes <- getsState $ actorNotProjList (isAtWar fact) arena       ours <- getsState $ actorNotProjAssocs (== side) arena-      Level{lxsize} <- getsState $ \s -> sdungeon s EM.! arena+      time <- getsState $ getLocalTime arena+      Level{lxsize, lysize} <- getsState $ \s -> sdungeon s EM.! arena+      actorD <- getsState sactorD+      let oldPos = bpos oldBody+          per = fper EM.! arena+          posOnLevel b | blid b /= arena = Nothing+                       | otherwise = Just $ bpos b+          mfoePos foe = maybe Nothing posOnLevel+                        $ EM.lookup foe actorD+          canSee foe = maybe False (actorSeesPos per oldAid) $ mfoePos foe+          isAmmo i = jsymbol i `elem` ritemProject (Kind.stdRuleset corule)+          hasAmmo = any (isAmmo . snd) oldAis+          isAdjacent = foesAdjacent lxsize lysize oldPos foes       if -- Keep the leader: he is alone on the level.          length ours == 1-         -- Keep the leader: it still has an enemy target (even if not visible)-         || case btarget of Just TEnemy{} -> True; _ -> False-            -- ... and he is not yet adjacent to any foe.-            && all (not . adjacent lxsize (bpos oldBody))-                   (map (bpos . snd) visFoes)+         -- Keep the leader: he has an enemy target.+         || case btarget of+              Just (TEnemy foe _) ->+                -- and he can shoot it.+                canSee foe && hasAmmo && not isAdjacent+              _ -> False+         -- Keep the leader: he probably just used stairs.+         || bpos oldBody == boldpos oldBody+            && not (waitedLastTurn oldBody time)         then queryAIPick oldAid         else do-          -- Visibility ignored --- every foe is visible by somebody.-          foes <- getsState $ actorNotProjAssocs (isAtWar fact) arena-          let f (aid, b) =+          let countMinFoeDist (aid, b) =                 let distB = chessDist lxsize (bpos b)-                    foeDist = map (\(_, body) -> distB (bpos body)) foes-                    minDist | null foeDist = maxBound-                            | otherwise = minimum foeDist-                    maxChaseDist = 30-                    maxProximity = max 1 $ maxChaseDist - minDist-                in if aid == oldAid || minDist == 1-                   then Nothing  -- ignore, leader or already in melee range-                   else Just (maxProximity, aid)-              candidates = mapMaybe f ours+                    foeDist = map (distB . bpos) foes+                    minFoeDist | null foeDist = maxBound+                               | otherwise = minimum foeDist+                in ((aid, b), minFoeDist)+              oursMinFoeDist = map countMinFoeDist ours+              inMelee (_, minFoeDist) = minFoeDist == 1+              oursMeleePos = map (bpos . snd . fst)+                             $ filter inMelee oursMinFoeDist+          let f ((aid, b), minFoeDist) =+                let distB = chessDist lxsize (bpos b)+                    meleeDist = map distB oursMeleePos+                    minMeleeDist | null meleeDist = maxBound+                                 | otherwise = minimum meleeDist+                    proximityMelee = max 0 $ 10 - minMeleeDist+                    proximityFoe = max 0 $ 20 - minFoeDist+                    distToLeader = distB oldPos+                    proximityLeader = max 0 $ 10 - distToLeader+                in if minFoeDist == 1+                      || bhp b <= 0+                      || aid == oldAid && waitedLastTurn b time+                   then -- Ignore: in melee range or incapacitated or stuck.+                        Nothing+                   else -- Help in melee, shoot or chase foes,+                        -- fan out away from each other, if too close.+                        Just ( 1+                               + proximityMelee * 9+                               + proximityFoe * 6+                               + proximityLeader * 3+                             , aid )+              candidates = mapMaybe f oursMinFoeDist               freq | null candidates = toFreq "old leader" [(1, oldAid)]                    | otherwise = toFreq "candidates for AI leader" candidates           aid <- rndToAction $ frequency freq@@ -87,26 +129,27 @@           modifyClient $ updateLeader aid s           queryAIPick aid -queryAIPick :: MonadClient m => ActorId -> m CmdSer+queryAIPick :: MonadClient m => ActorId -> m CmdSerTakeTime queryAIPick aid = do+  Kind.COps{cofact=Kind.Ops{okind}} <- getsState scops   side <- getsClient sside   body <- getsState $ getActorBody aid-  assert (bfid body == side `blame` (aid, bfid body, side)) skip-  Kind.COps{costrat=Kind.Ops{okind}} <- getsState scops-  leader <- getsClient _sleader+  assert (bfid body == side `blame` "AI tries to move enemy actor"+                            `with` (aid, bfid body, side)) skip+  mleader <- getsClient _sleader   fact <- getsState $ (EM.! bfid body) . sfactionD-  let factionAI | Just aid /= leader = fromJust $ gAiMember fact-                | otherwise = fromJust $ gAiLeader fact-      factionAbilities = sabilities (okind factionAI)+  let factionAbilities+        | Just aid == mleader = fAbilityLeader $ okind $ gkind fact+        | otherwise = fAbilityOther $ okind $ gkind fact   unless (bproj body) $ do     stratTarget <- targetStrategy aid factionAbilities     -- Choose a target from those proposed by AI for the actor.     btarget <- rndToAction $ frequency $ bestVariant stratTarget     let _debug = T.unpack           $ "\nHandleAI abilities:" <+> showT factionAbilities-          <>          ", symbol:"   <+> showT (bsymbol body)-          <>          ", aid:"      <+> showT aid-          <>          ", pos:"      <+> showT (bpos body)+          <> ", symbol:"            <+> showT (bsymbol body)+          <> ", aid:"               <+> showT aid+          <> ", pos:"               <+> showT (bpos body)           <> "\nHandleAI starget:"  <+> showT stratTarget           <> "\nHandleAI target:"   <+> showT btarget --    trace _debug skip@@ -115,18 +158,19 @@   -- Run the AI: chose an action from those given by the AI strategy.   action <- rndToAction $ frequency $ bestVariant stratAction   let _debug = T.unpack-          $    "HandleAI saction:"  <+> showT stratAction-          <> "\nHandleAI action:"   <+> showT action+          $ "HandleAI saction:"   <+> showT stratAction+          <> "\nHandleAI action:" <+> showT action --  trace _debug skip   return action --- | Handle the move of the hero.+-- | Handle the move of a UI player. queryUI :: (MonadClientAbort m, MonadClientUI m) => ActorId -> m CmdSer queryUI aid = do   -- When running, stop if aborted by a disturbance. Otherwise let   -- the human player issue commands, until any of them takes time.   leader <- getLeaderUI-  assert (leader == aid `blame` (leader, aid)) skip+  assert (leader == aid `blame` "player moves not his leader"+                        `with` (leader, aid)) skip   let inputHumanCmd msg = do         stopRunning         humanCommand msg@@ -139,8 +183,8 @@ continueRun leader dd = do   (dir, distNew) <- continueRunDir leader dd   modifyClient $ \cli -> cli {srunning = Just (dir, distNew)}-  -- Attacks and opening doors disallowed when continuing to run.-  return $ RunSer leader dir+  -- The potential invisible actor is hit. War is started without asking.+  return $ TakeTimeSer $ MoveSer leader dir  -- | Determine and process the next human player command. The argument is -- the last abort message due to running, if any.@@ -176,7 +220,10 @@         -- The command was aborted or successful and if the latter,         -- possibly took some time.         case mcmdS of-          Just cmdS -> assert (null (runSlideshow slides) `blame` slides) $ do+          Just cmdS -> do+            assert (null (runSlideshow slides)+                    `blame` "some slides generated for server command"+                    `with` slides) skip             -- Exit the loop and let other actors act. No next key needed             -- and no slides could have been generated.             modifyClient (\st -> st {slastKey = Nothing})@@ -192,8 +239,8 @@                 -- for all but the last one.                 -- Note: the code that generates the slides is responsible                 -- for inserting the @more@ prompt.-                b <- getInitConfirms [km] $ toSlideshow $ reverse sls-                return $! if b then Just sLast else Nothing+                go <- getInitConfirms ColorFull [km] $ toSlideshow $ reverse sls+                return $! if go then Just sLast else Nothing             case mLast of               Nothing -> do                 -- Display current state if no slideshow or interrupted.
Game/LambdaHack/Client/Config.hs view
@@ -13,15 +13,18 @@ -- is a part of a game client. data ConfigUI = ConfigUI   { -- commands-    configCommands     :: ![(K.KM, HumanCmd)]+    configCommands   :: ![(K.KM, HumanCmd)]     -- files-  , configAppDataDirUI :: !FilePath-  , configUICfgFile    :: !FilePath+  , configAppDataDir :: !FilePath+  , configUICfgFile  :: !FilePath+  , configSavePrefix :: !String     -- macros-  , configMacros       :: ![(K.KM, K.KM)]+  , configMacros     :: ![(K.KM, K.KM)]     -- ui-  , configFont         :: !String-  , configHistoryMax   :: !Int+  , configFont       :: !String+  , configHistoryMax :: !Int+  , configMaxFps     :: !Int+  , configNoAnim     :: !Bool   }   deriving Show @@ -30,16 +33,22 @@ instance Binary ConfigUI where   put ConfigUI{..} = do     put configCommands-    put configAppDataDirUI+    put configAppDataDir     put configUICfgFile+    put configSavePrefix     put configMacros     put configFont     put configHistoryMax+    put configMaxFps+    put configNoAnim   get = do-    configCommands     <- get-    configAppDataDirUI <- get-    configUICfgFile    <- get-    configMacros       <- get-    configFont         <- get-    configHistoryMax   <- get+    configCommands <- get+    configAppDataDir <- get+    configUICfgFile <- get+    configSavePrefix <- get+    configMacros <- get+    configFont <- get+    configHistoryMax <- get+    configMaxFps <- get+    configNoAnim <- get     return ConfigUI{..}
Game/LambdaHack/Client/Draw.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Display game data on the screen using one of the available frontends -- (determined at compile time with cabal flags). module Game.LambdaHack.Client.Draw@@ -49,8 +48,7 @@      StateClient{ stgtMode, scursor, seps, sdisco                 , smarkVision, smarkSmell, smarkSuspect }      s overlay =-  let Kind.COps{ coactor=Kind.Ops{okind}-               , cotile=Kind.Ops{okind=tokind, ouniqGroup} } = cops+  let Kind.COps{cotile=Kind.Ops{okind=tokind, ouniqGroup}} = cops       (lvl@Level{ ldepth, lxsize, lysize, lsmell                 , ldesc, ltime, lseen, lclear }) = sdungeon s EM.! drawnLevelId       (msgTop, over, msgBottom) = stringByLocation lxsize lysize overlay@@ -79,14 +77,13 @@             items = lvl `atI` pos0             sml = EM.findWithDefault timeZero pos0 lsmell             smlt = sml `timeAdd` timeNegate ltime-            viewActor aid Actor{bkind, bsymbol, bcolor, bhp, bproj}+            viewActor aid Actor{bsymbol, bcolor, bhp, bproj}               | Just aid == mleader = (symbol, Color.defBG)               | otherwise = (symbol, color)              where-              ActorKind{asymbol, acolor} = okind bkind-              color  = fromMaybe acolor bcolor+              color  = bcolor               symbol | bhp <= 0 && not bproj = '%'-                     | otherwise = fromMaybe asymbol bsymbol+                     | otherwise = bsymbol             rainbow p = toEnum $ fromEnum p `rem` 14 + 1             actorsHere = actorAssocs (const True) drawnLevelId s             -- smarkSuspect is an optional overlay, so let's overlay it@@ -123,7 +120,7 @@                     i : _ -> Item.viewItem $ getItemBody i s             vis = ES.member pos0 $ totalVisible per             visPl =-              maybe False (\leader -> actorSeesLoc per leader pos0) mleader+              maybe False (\leader -> actorSeesPos per leader pos0) mleader             bg0 = if isJust stgtMode && Just pos0 == scursor                   then Color.defFG       -- highlight target cursor                   else sVisBG vis visPl  -- FOV debug or standard bg@@ -145,7 +142,7 @@       seenN = 100 * lseen `div` lclear       seenTxt | seenN == 100 = "all"               | otherwise = T.justifyRight 2 ' ' (showT seenN) <> "%"-      lvlN = T.justifyLeft 2 ' ' (showT ldepth)+      lvlN = T.justifyLeft 2 ' ' (showT $ abs ldepth)       stats =         T.justifyLeft 11 ' ' ("[" <> seenTxt <+> "seen]") <+>         T.justifyLeft 9 ' ' ("$:" <+> showT wealth) <+>
Game/LambdaHack/Client/HumanCmd.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} -- | Abstract syntax human player commands. module Game.LambdaHack.Client.HumanCmd   ( HumanCmd(..), Trigger(..)@@ -18,29 +18,29 @@ -- | Abstract syntax of player commands. data HumanCmd =     -- These usually take time.-    Move VectorXY-  | Run VectorXY+    Move !VectorXY+  | Run !VectorXY   | Wait   | Pickup   | Drop-  | Project     [Trigger]-  | Apply       [Trigger]-  | TriggerDir  [Trigger]-  | TriggerTile [Trigger]+  | Project     ![Trigger]+  | Apply       ![Trigger]+  | AlterDir    ![Trigger]+  | TriggerTile ![Trigger]     -- These do not take time.-  | GameRestart Text+  | GameRestart !Text   | GameExit   | GameSave   | CfgDump     -- These do not notify the server.-  | SelectHero Int+  | SelectHero !Int   | MemberCycle   | MemberBack   | Inventory   | TgtFloor   | TgtEnemy-  | TgtAscend Int-  | EpsIncr Bool+  | TgtAscend !Int+  | EpsIncr !Bool   | Cancel   | Accept   | Clear@@ -54,8 +54,9 @@ instance Binary HumanCmd  data Trigger =-    ApplyItem {verb :: MU.Part, object :: MU.Part, symbol :: Char}-  | BumpFeature {verb :: MU.Part, object :: MU.Part, feature :: F.Feature}+    ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char}+  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}+  | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}   deriving (Show, Read, Eq, Ord, Generic)  instance Binary Trigger@@ -67,7 +68,7 @@   Drop          -> True   Project{}     -> True   Apply{}       -> True-  TriggerDir{}  -> True+  AlterDir{}    -> True   TriggerTile{} -> True   Inventory     -> True   Help          -> True@@ -104,7 +105,7 @@   Drop          -> True   Project{}     -> True   Apply{}       -> True-  TriggerDir{}  -> True+  AlterDir{}    -> True   TriggerTile{} -> True   _             -> False @@ -118,7 +119,7 @@   Drop        -> "drop an object"   Project ts     -> triggerDescription ts   Apply ts       -> triggerDescription ts-  TriggerDir ts  -> triggerDescription ts+  AlterDir ts -> triggerDescription ts   TriggerTile ts -> triggerDescription ts    GameRestart t -> "new" <+> t <+> "game"@@ -137,7 +138,7 @@   TgtAscend k | k == -1 -> "target next deeper level"   TgtAscend k | k <= -2 -> "target" <+> showT (-k) <+> "levels deeper"   TgtAscend _ ->-    assert `failure` ("void level change in targeting in config file" :: Text)+    assert `failure` "void level change when targeting" `with` cmd   EpsIncr True  -> "swerve targeting line"   EpsIncr False -> "unswerve targeting line"   Cancel      -> "cancel action"
Game/LambdaHack/Client/HumanGlobal.hs view
@@ -1,11 +1,9 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Semantics of 'Command.Cmd' client commands that return server commands. -- A couple of them do not take time, the rest does. -- TODO: document module Game.LambdaHack.Client.HumanGlobal-  ( moveLeader, exploreLeader, runLeader, waitHuman, pickupHuman, dropHuman-  , projectLeader, applyHuman, triggerDirHuman, triggerTileHuman+  ( moveRunAid, displaceAid, meleeAid, waitHuman, pickupHuman, dropHuman+  , projectAid, applyHuman, alterDirHuman, triggerTileHuman   , gameRestartHuman, gameExitHuman, gameSaveHuman, cfgDumpHuman   ) where @@ -22,7 +20,6 @@ import Game.LambdaHack.Client.Draw import Game.LambdaHack.Client.HumanCmd (Trigger (..)) import Game.LambdaHack.Client.HumanLocal-import Game.LambdaHack.Client.RunAction import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor@@ -44,45 +41,99 @@ import Game.LambdaHack.Content.TileKind as TileKind import Game.LambdaHack.Utils.Assert --- * Move--moveLeader :: MonadClientUI m => Vector -> m CmdSer-moveLeader dir = do-  leader <- getLeaderUI-  return $! MoveSer leader dir+abortFailure :: MonadClientAbort m => FailureSer -> m a+abortFailure = abortWith . showFailureSer --- * Explore+-- * Move and Run -exploreLeader :: MonadClientUI m => Vector -> m CmdSer-exploreLeader dir = do-  leader <- getLeaderUI-  return $! ExploreSer leader dir+-- | Actor atttacks an enemy actor or his own projectile.+meleeAid :: (MonadClientAbort m, MonadClientUI m)+          => ActorId -> ActorId -> m CmdSerTakeTime+meleeAid source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  sfact <- getsState $ (EM.! bfid sb) . sfactionD+  unless (bproj tb || isAtWar sfact (bfid tb)) $ do+    go <- displayYesNo ColorBW+            "This attack will start a war. Are you sure?"+    unless go $ abortWith "Attack canceled."+  unless (bproj tb || not (isAllied sfact (bfid tb))) $ do+    go <- displayYesNo ColorBW+            "You are bound by an alliance. Really attack?"+    unless go $ abortWith "Attack canceled."+  return $ MeleeSer source target+  -- Seeing the actor prevents altering a tile under it, but that+  -- does not limit the player, he just doesn't waste a turn+  -- on a failed altering. --- * Run+-- | Actor swaps position with another.+displaceAid :: (MonadClientAbort m, MonadClientUI m)+            => ActorId -> ActorId -> m CmdSerTakeTime+displaceAid source target = do+  cops <- getsState scops+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  let lid = blid sb+  lvl <- getLevel lid+  let spos = bpos sb+      tpos = bpos tb+  if accessible cops lvl spos tpos then+    -- Displacing requires full access.+    return $ DisplaceSer source target+  else abortFailure DisplaceAccess -runLeader :: MonadClientUI m => Vector -> m CmdSer-runLeader dir = do-  leader <- getLeaderUI-  canR <- canRun leader (dir, 0)-  when canR $ modifyClient $ \cli -> cli {srunning = Just (dir, 1)}-  -- Run even if blocked (and then stop), e.g., to open a door.-  return $! RunSer leader dir+-- | Actor moves or searches or alters. No visible actor at the position.+moveRunAid :: (MonadClientAbort m, MonadClientUI m)+           => ActorId -> Vector -> m CmdSerTakeTime+moveRunAid source dir = do+  cops@Kind.COps{cotile} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+  lvl <- getLevel lid+  let spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+      t = lvl `at` tpos+  -- Movement requires full access.+  if accessible cops lvl spos tpos then+    -- The potential invisible actor is hit. War is started without asking.+    return $ MoveSer source dir+  -- No access, so search and/or alter the tile.+  else if not (Tile.hasFeature cotile F.Walkable t)  -- not implied by access+          && (Tile.hasFeature cotile F.Suspect t+              || Tile.openable cotile t+              || Tile.closable cotile t+              || Tile.changeable cotile t) then+    if not $ EM.null $ lvl `atI` tpos then abortFailure AlterBlockItem+    else return $ AlterSer source tpos Nothing+    -- We don't use MoveSer, because we don't hit invisible actors here.+    -- The potential invisible actor, e.g., in a wall or in+    -- an inaccessible doorway, is made known, taking a turn.+    -- If server performed an attack for free on the invisible actor anyway,+    -- the player (or AI) would be tempted to repeatedly+    -- hit random walls in hopes of killing a monster lurking within.+    -- If the action had a cost, misclicks would incur the cost, too.+    -- Right now the player may repeatedly alter tiles trying to learn+    -- about invisible pass-wall actors, but it costs a turn+    -- and does not harm the invisible actors, so it's not tempting.+  else+    -- Ignore a known boring, not accessible tile.+    neverMind True  -- * Wait  -- | Leader waits a turn (and blocks, etc.).-waitHuman :: MonadClientUI m => m CmdSer+waitHuman :: MonadClientUI m => m CmdSerTakeTime waitHuman = do   leader <- getLeaderUI   return $ WaitSer leader  -- * Pickup -pickupHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer+pickupHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSerTakeTime pickupHuman = do   leader <- getLeaderUI   body <- getsState $ getActorBody leader-  lvl <- getsLevel (blid body) id+  lvl <- getLevel $ blid body   -- Check if something is here to pick up. Items are never invisible.   case EM.minViewWithKey $ lvl `atI` bpos body of     Nothing -> abortWith "nothing here"@@ -98,7 +149,7 @@ -- TODO: you can drop an item already on the floor, which works correctly, -- but is weird and useless. -- | Drop a single item.-dropHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer+dropHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSerTakeTime dropHuman = do   -- TODO: allow dropping a given number of identical items.   Kind.COps{coitem} <- getsState scops@@ -147,7 +198,7 @@ getItem aid prompt p ptext bag inv isn = do   leader <- getLeaderUI   b <- getsState $ getActorBody leader-  lvl <- getsLevel (blid b) id+  lvl <- getLevel $ blid b   s <- getState   body <- getsState $ getActorBody aid   let checkItem (l, iid) =@@ -202,66 +253,79 @@                            ((iid, getItemBody iid s),                             (k, CFloor (blid b) pos)))                    $ EM.assocs tis-          K.Char l | InvChar l `elem` map (snd . snd) ims ->+          K.Char l ->             case find ((InvChar l ==) . snd . snd) ims of-              Nothing -> assert `failure` (l,  ims)+              Nothing -> assert `failure` "unexpected inventory letter"+                                `with` (km, l,  ims)               Just (iidItem, (k, l2)) ->                 return (iidItem, (k, CActor aid l2))           K.Return | bestFull ->             let (iidItem, (k, l2)) = maximumBy (compare `on` snd . snd) isp             in return (iidItem, (k, CActor aid l2))-          _ -> assert `failure` "perform: unexpected key:" <+> K.showKM km+          _ -> assert `failure` "unexpected key:" `with` km   ask  -- * Project -projectLeader :: (MonadClientAbort m, MonadClientUI m)-              => [Trigger] -> m CmdSer-projectLeader ts = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  let lid = blid b-  ms <- getsState $ actorNotProjList (isAtWar fact) lid-  lxsize <- getsLevel lid lxsize-  lysize <- getsLevel lid lysize-  if foesAdjacent lxsize lysize (bpos b) ms-    then abortWith "You can't aim in melee."-    else actorProjectGI leader ts--actorProjectGI :: (MonadClientAbort m, MonadClientUI m)-               => ActorId -> [Trigger] -> m CmdSer-actorProjectGI aid ts = do-  seps <- getsClient seps+projectAid :: (MonadClientAbort m, MonadClientUI m)+           => ActorId -> [Trigger] -> m CmdSerTakeTime+projectAid source ts = do+  Kind.COps{cotile} <- getsState scops   target <- targetToPos+  let tpos = case target of+        Just p -> p+        Nothing -> assert `failure` "target unexpectedly invalid" `with` source+  eps <- getsClient seps+  sb <- getsState $ getActorBody source+  let lid = blid sb+      spos = bpos sb+  fact <- getsState $ (EM.! bfid sb) . sfactionD+  Level{lxsize, lysize} <- getLevel lid+  foes <- getsState $ actorNotProjList (isAtWar fact) lid+  if foesAdjacent lxsize lysize spos foes+    then abortFailure ProjectBlockFoes+    else do+      case bla lxsize lysize eps spos tpos of+        Nothing -> abortFailure ProjectAimOnself+        Just [] -> assert `failure` "project from the edge of level"+                          `with` (spos, tpos, sb, ts)+        Just (pos : _) -> do+          as <- getsState $ actorList (const True) lid+          lvl <- getLevel lid+          let t = lvl `at` pos+          if not $ Tile.hasFeature cotile F.Clear t+            then abortFailure ProjectBlockTerrain+            else if unoccupied as pos+                 then projectBla source tpos eps ts+                 else abortFailure ProjectBlockActor++projectBla :: (MonadClientAbort m, MonadClientUI m)+           => ActorId -> Point -> Int -> [Trigger] -> m CmdSerTakeTime+projectBla source tpos eps ts = do   let (verb1, object1) = case ts of         [] -> ("aim", "object")         tr : _ -> (verb tr, object tr)       triggerSyms = triggerSymbols ts-  case target of-    Just p -> do-      bag <- getsState $ getActorBag aid-      inv <- getsState $ getActorInv aid-      ((iid, _), (_, container)) <--        getGroupItem aid bag inv object1 triggerSyms-          (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"-      stgtMode <- getsClient stgtMode-      case stgtMode of-        Just (TgtAuto _) -> endTargeting True-        _ -> return ()-      return $! ProjectSer aid p seps iid container-    Nothing -> assert `failure` (aid, "target unexpectedly invalid")+  bag <- getsState $ getActorBag source+  inv <- getsState $ getActorInv source+  ((iid, _), (_, container)) <-+    getGroupItem source bag inv object1 triggerSyms+      (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"+  stgtMode <- getsClient stgtMode+  case stgtMode of+    Just (TgtAuto _) -> endTargeting True+    _ -> return ()+  return $! ProjectSer source tpos eps iid container  triggerSymbols :: [Trigger] -> [Char] triggerSymbols [] = []-triggerSymbols (ApplyItem{..} : ts) = symbol : triggerSymbols ts+triggerSymbols (ApplyItem{symbol} : ts) = symbol : triggerSymbols ts triggerSymbols (_ : ts) = triggerSymbols ts  -- * Apply  applyHuman :: (MonadClientAbort m, MonadClientUI m)-           => [Trigger] -> m CmdSer+           => [Trigger] -> m CmdSerTakeTime applyHuman ts = do   leader <- getLeaderUI   bag <- getsState $ getActorBag leader@@ -292,45 +356,82 @@       header = makePhrase [MU.Capitalize (MU.Ws object)]   getItem leader prompt choice header is inv packName --- * TriggerDir+-- * AlterDir --- | Ask for a direction and trigger a tile, if possible.-triggerDirHuman :: (MonadClientAbort m, MonadClientUI m)-                => [Trigger] -> m CmdSer-triggerDirHuman ts = do+-- | Ask for a direction and alter a tile, if possible.+alterDirHuman :: (MonadClientAbort m, MonadClientUI m)+              => [Trigger] -> m CmdSerTakeTime+alterDirHuman ts = do   let verb1 = case ts of-        [] -> "trigger"+        [] -> "alter"         tr : _ -> verb tr       keys = zipWith K.KM (repeat K.NoModifier) K.dirAllMoveKey       prompt = makePhrase ["What to", verb1 MU.:> "? [movement key"]   e <- displayChoiceUI prompt [] keys   leader <- getLeaderUI   b <- getsState $ getActorBody leader-  let dpos dir = bpos b `shift` dir-  lxsize <- getsLevel (blid b) lxsize-  K.handleDir lxsize e (bumpTile leader ts . dpos) (neverMind True)+  Level{lxsize} <- getLevel $ blid b+  K.handleDir lxsize e (flip (alterTile leader) ts) (neverMind True) +-- | Player tries to alter a tile using a feature.+alterTile :: (MonadClientAbort m, MonadClientUI m)+          => ActorId -> Vector -> [Trigger] -> m CmdSerTakeTime+alterTile source dir ts = do+  Kind.COps{cotile} <- getsState scops+  b <- getsState $ getActorBody source+  lvl <- getLevel $ blid b+  let tpos = bpos b `shift` dir+      t = lvl `at` tpos+      alterFeats = alterFeatures ts+  case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of+    [] -> guessAlter cotile alterFeats t+    feat : _ -> return $! AlterSer source tpos $ Just feat++alterFeatures :: [Trigger] -> [F.Feature]+alterFeatures [] = []+alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts+alterFeatures (_ : ts) = alterFeatures ts++-- | Guess and report why the bump command failed.+guessAlter :: MonadClientAbort m+           => Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> m a+guessAlter cotile (F.OpenTo _ : _) t | Tile.closable cotile t =+  abortWith "already open"+guessAlter _ (F.OpenTo _ : _) _ =+  abortWith "can't be opened"+guessAlter cotile (F.CloseTo _ : _) t | Tile.openable cotile t =+  abortWith "already closed"+guessAlter _ (F.CloseTo _ : _) _ =+  abortWith "can't be closed"+guessAlter _ _ _ = neverMind True++-- * TriggerTile++-- | Leader tries to trigger the tile he's standing on.+triggerTileHuman :: (MonadClientAbort m, MonadClientUI m)+                 => [Trigger] -> m CmdSerTakeTime+triggerTileHuman ts = do+  leader <- getLeaderUI+  triggerTile leader ts+ -- | Player tries to trigger a tile using a feature.--- To help the player, only visible features can be triggered.-bumpTile :: (MonadClientAbort m, MonadClientUI m)-         => ActorId -> [Trigger] -> Point -> m CmdSer-bumpTile leader ts dpos = do+triggerTile :: (MonadClientAbort m, MonadClientUI m)+            => ActorId -> [Trigger] -> m CmdSerTakeTime+triggerTile leader ts = do   Kind.COps{cotile} <- getsState scops   b <- getsState $ getActorBody leader-  lvl <- getsLevel (blid b) id-  let t = lvl `at` dpos+  lvl <- getLevel $ blid b+  let t = lvl `at` bpos b       triggerFeats = triggerFeatures ts-  -- A tile can be triggered even if an invisible monster occupies it.-  -- TODO: let the user choose whether to attack or activate.   case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of-    [] -> guessBump cotile triggerFeats t-    fs -> do-      mapM_ (verifyTrigger leader) fs-      return $ TriggerSer leader dpos+    [] -> guessTrigger cotile triggerFeats t+    feat : _ -> do+      verifyTrigger leader feat+      return $! TriggerSer leader $ Just feat  triggerFeatures :: [Trigger] -> [F.Feature] triggerFeatures [] = []-triggerFeatures (BumpFeature{..} : ts) = feature : triggerFeatures ts+triggerFeatures (TriggerFeature{feature} : ts) = feature : triggerFeatures ts triggerFeatures (_ : ts) = triggerFeatures ts  -- | Verify important feature triggers, such as fleeing the dungeon.@@ -358,36 +459,24 @@   _ -> return ()  -- | Guess and report why the bump command failed.-guessBump :: MonadClientAbort m => Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> m a-guessBump cotile (F.Openable : _) t | Tile.hasFeature cotile F.Closable t =-  abortWith "already open"-guessBump _ (F.Openable : _) _ =-  abortWith "not a door"-guessBump cotile (F.Closable : _) t | Tile.hasFeature cotile F.Openable t =-  abortWith "already closed"-guessBump _ (F.Closable : _) _ =-  abortWith "not a door"-guessBump cotile (F.Cause (Effect.Ascend _) : _) t-  | Tile.hasFeature cotile F.Descendable t =-    abortWith "the way goes down, not up"-guessBump _ (F.Cause (Effect.Ascend _) : _) _ =-  abortWith "no stairs up"-guessBump cotile (F.Cause (Effect.Descend _) : _) t-  | Tile.hasFeature cotile F.Ascendable t =-    abortWith "the way goes up, not down"-guessBump _ (F.Cause (Effect.Descend _) : _) _ =-  abortWith "no stairs down"-guessBump _ _ _ = neverMind True---- * TriggerTile---- | Leader tries to trigger the tile he's standing on.-triggerTileHuman :: (MonadClientAbort m, MonadClientUI m)-                 => [Trigger] -> m CmdSer-triggerTileHuman ts = do-  leader <- getLeaderUI-  ppos <- getsState (bpos . getActorBody leader)-  bumpTile leader ts ppos+guessTrigger :: MonadClientAbort m+             => Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> m a+guessTrigger cotile fs@(F.Cause (Effect.Ascend k) : _) t+  | Tile.hasFeature cotile (F.Cause (Effect.Ascend (-k))) t =+    if k > 0 then+      abortWith "the way goes down, not up"+    else if k < 0 then+      abortWith "the way goes up, not down"+    else+      assert `failure` fs+guessTrigger _ fs@(F.Cause (Effect.Ascend k) : _) _ =+    if k > 0 then+      abortWith "can't ascend"+    else if k < 0 then+      abortWith "can't descend"+    else+      assert `failure` fs+guessTrigger _ _ _ = neverMind True  -- * GameRestart; does not take time @@ -409,8 +498,8 @@  gameExitHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer gameExitHuman = do-  b <- displayYesNo ColorFull "Really save and exit?"-  if b then do+  go <- displayYesNo ColorFull "Really save and exit?"+  if go then do     leader <- getLeaderUI     return $ GameExitSer leader   else abortWith "Save and exit canceled."
Game/LambdaHack/Client/HumanLocal.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Semantics of 'HumanCmd' client commands that do not return -- server commands. None of such commands takes game time. -- TODO: document@@ -56,6 +54,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Utils.Assert  -- * Move and Run@@ -75,8 +74,9 @@ cursorLevel = do   dungeon <- getsState sdungeon   stgtMode <- getsClient stgtMode-  let tgtId =-        maybe (assert `failure` "not targetting right now") tgtLevelId stgtMode+  cli <- getClient+  let tgtId = maybe (assert `failure` "not targetting right now"+                            `with` cli) tgtLevelId stgtMode   return $! dungeon EM.! tgtId  viewedLevel :: MonadClientUI m => m (LevelId, Level)@@ -99,7 +99,7 @@        -> Text       -- ^ an extra sentence to print        -> m Text lookAt detailed canSee pos aid msg = do-  Kind.COps{coitem, cotile=Kind.Ops{oname}} <- getsState scops+  Kind.COps{coitem, cotile=cotile@Kind.Ops{okind}} <- getsState scops   (_, lvl) <- viewedLevel   subject <- partAidLeader aid   s <- getState@@ -114,16 +114,18 @@                              , MU.WWandW $ map nWs $ EM.assocs is]               True -> "Objects:"               _ -> "Objects here."+      tile = lvl `at` pos+      obscured | tile /= hideTile cotile lvl pos = "partially obscured"+               | otherwise = ""   if detailed-    then let tile = lvl `at` pos-         in return $! makeSentence [MU.Text $ oname tile] <+> msg <+> isd+    then return $! makeSentence [obscured, MU.Text $ tname $ okind tile]+                   <+> msg <+> isd     else return $! msg <+> isd  -- | Perform look around in the current position of the cursor. -- Assumes targeting mode and so assumes that a leader is selected. doLook :: MonadClientUI m => WriterT Slideshow m () doLook = do-  Kind.COps{coactor} <- getsState scops   scursor <- getsClient scursor   (lid, lvl) <- viewedLevel   per <- getPerFid lid@@ -137,12 +139,12 @@                 | otherwise = Nothing       enemyMsg =         -- Even if it's the leader, give his proper name, not 'you'.-        maybe "" (\m -> let subject = partActor coactor m+        maybe "" (\b -> let subject = partActor b                             verb = "be here"                         in makeSentence [MU.SubjectVerbSg subject verb])               ihabitant       vis | not $ p `ES.member` totalVisible per = " (not visible)"-          | actorSeesLoc per leader p = ""+          | actorSeesPos per leader p = ""           | otherwise = " (not visible)"       mode = case target of                Just TEnemy{} -> "[targeting foe" <> vis <> "]"@@ -220,7 +222,7 @@     [] -> abortWith "Cannot select any other member on this level."     (np, b) : _ -> do       success <- selectLeader np-      assert (success `blame` (leader, np, b)) skip+      assert (success `blame` "same leader" `with` (leader, np, b)) skip  partyAfterLeader :: MonadActionRO m                  => ActorId@@ -240,20 +242,20 @@ -- | Select a faction leader. False, if nothing to do. selectLeader :: MonadClientUI m => ActorId -> m Bool selectLeader actor = do-  Kind.COps{coactor} <- getsState scops   leader <- getLeaderUI   stgtMode <- getsClient stgtMode   if leader == actor     then return False -- already selected     else do       pbody <- getsState $ getActorBody actor+      assert (not (bproj pbody) `blame` "projectile chosen as the leader"+                                `with` (actor, pbody)) skip       -- Even if it's already the leader, give his proper name, not 'you'.-      let subject = partActor coactor pbody+      let subject = partActor pbody       msgAdd $ makeSentence [subject, "selected"]       -- Update client state.       s <- getState       modifyClient $ updateLeader actor s-      assert (not (bproj pbody) `blame` (actor, pbody)) skip       -- Move the cursor, if active, to the new level.       when (isJust stgtMode) $ setTgtId $ blid pbody       -- Inform about items, etc.@@ -277,7 +279,7 @@     [] -> abortWith "No other member in the party."     (np, b) : _ -> do       success <- selectLeader np-      assert (success `blame` (leader, np, b)) skip+      assert (success `blame` "same leader" `with` (leader, np, b)) skip  -- * Inventory @@ -351,22 +353,21 @@   stgtMode <- getsClient stgtMode   side <- getsClient sside   fact <- getsState $ (EM.! side) . sfactionD-  ms <- getsState $ actorNotProjAssocs (isAtWar fact) lid-  let plms = filter ((/= leader) . fst) ms  -- don't target yourself-      ordPos (_, m) = (chessDist lxsize ppos $ bpos m, bpos m)-      dms = sortBy (comparing ordPos) plms+  bs <- getsState $ actorNotProjAssocs (isAtWar fact) lid+  let ordPos (_, m) = (chessDist lxsize ppos $ bpos m, bpos m)+      dbs = sortBy (comparing ordPos) bs       (lt, gt) = case target of             Just (TEnemy n _) | isJust stgtMode ->  -- pick next enemy-              let i = fromMaybe (-1) $ findIndex ((== n) . fst) dms-              in splitAt (i + 1) dms+              let i = fromMaybe (-1) $ findIndex ((== n) . fst) dbs+              in splitAt (i + 1) dbs             Just (TEnemy n _) ->  -- try to retarget the old enemy-              let i = fromMaybe (-1) $ findIndex ((== n) . fst) dms-              in splitAt i dms-            _ -> (dms, [])  -- target first enemy (e.g., number 0)+              let i = fromMaybe (-1) $ findIndex ((== n) . fst) dbs+              in splitAt i dbs+            _ -> (dbs, [])  -- target first enemy (e.g., number 0)       gtlt = gt ++ lt       seen (_, m) =-        let mpos = bpos m            -- it is remembered by faction-        in actorSeesLoc per leader mpos  -- is it visible by actor?+        let mpos = bpos m                -- it is remembered by faction+        in actorSeesPos per leader mpos  -- is it visible by actor?       lf = filter seen gtlt       tgt = case lf of               [] -> target  -- no enemies in sight, stick to last target@@ -384,31 +385,27 @@ tgtAscendHuman k = do   Kind.COps{cotile} <- getsState scops   dungeon <- getsState sdungeon-  s <- getState   cursor <- getsClient scursor   (tgtId, lvl) <- viewedLevel   let rightStairs = case cursor of-        Nothing -> False+        Nothing -> Nothing         Just cpos ->           let tile = lvl `at` cpos-          in k ==  1-             && Tile.hasFeature cotile (F.Cause $ Effect.Ascend 1)  tile-             || k == -1-             && Tile.hasFeature cotile (F.Cause $ Effect.Descend 1) tile-  if rightStairs  -- stairs, in the right direction-    then case whereTo s tgtId k of-      Nothing ->  -- we are at the "end" of the dungeon-        abortWith "no more levels in this direction"-      Just (nln, npos) ->-        assert (nln /= tgtId `blame` (nln, "stairs looped")) $ do-          -- Do not freely reveal the other end of the stairs.-          let scursor =-                if Tile.hasFeature cotile F.Exit (lvl `at` npos)-                then Just npos  -- already know as an exit, focus on it-                else cursor    -- unknown, do not reveal-          modifyClient $ \cli -> cli {scursor}-          setTgtId nln-    else  -- no stairs in the right direction+          in if Tile.hasFeature cotile (F.Cause $ Effect.Ascend k) tile+             then Just cpos+             else Nothing+  case rightStairs of+    Just cpos -> do  -- stairs, in the right direction+      (nln, npos) <- getsState $ whereTo tgtId cpos k+      assert (nln /= tgtId `blame` "stairs looped" `with` nln) skip+      -- Do not freely reveal the other end of the stairs.+      let scursor =+            if Tile.hasFeature cotile F.Exit (lvl `at` npos)+            then Just npos  -- already know as an exit, focus on it+            else cursor    -- unknown, do not reveal+      modifyClient $ \cli -> cli {scursor}+      setTgtId nln+    Nothing ->  -- no stairs in the right direction       case ascendInBranch dungeon tgtId k of         [] -> abortWith "no more levels in this direction"         nln : _ -> setTgtId nln@@ -451,9 +448,7 @@ displayMainMenu = do   Kind.COps{corule} <- getsState scops   Binding{krevMap} <- askBinding-  let stripFrame t = case T.uncons t of-        Just ('\n', art) -> map (T.tail . T.init) $ tail . init $ T.lines art-        _ -> assert `failure` "displayMainMenu:" <+> t+  let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t       pasteVersion art =         let pathsVersion = rpathsVersion $ Kind.stdRuleset corule             version = " Version " ++ showVersion pathsVersion@@ -465,8 +460,7 @@       kds =  -- key-description pairs         let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd)             revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd krevMap-            cmds = [ HumanCmd.GameSave-                   , HumanCmd.GameExit+            cmds = [ HumanCmd.GameExit                    , HumanCmd.GameRestart "campaign"                    , HumanCmd.GameRestart "skirmish"                    , HumanCmd.GameRestart "PvP"@@ -496,7 +490,7 @@       menuOverlay =  -- TODO: switch to Text and use T.justifyLeft         overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt   case menuOverlay of-    [] -> assert `failure` "empty Main Menu overlay"+    [] -> assert `failure` "empty Main Menu overlay" `with` mainMenuArt     hd : tl -> do       slides <- overlayToSlideshow hd tl  -- TODO: keys don't work if tl/=[]       tell slides@@ -523,12 +517,12 @@     (lid, _) <- viewedLevel     side <- getsClient sside     fact <- getsState $ (EM.! side) . sfactionD-    ms <- getsState $ actorNotProjAssocs (isAtWar fact) lid+    bs <- getsState $ actorNotProjAssocs (isAtWar fact) lid     case target of       Just TEnemy{} ->         -- If in enemy targeting mode, switch to the enemy under         -- the current cursor position, if any.-        case find (\ (_im, m) -> Just (bpos m) == scursor) ms of+        case find (\ (_im, m) -> Just (bpos m) == scursor) bs of           Just (im, m)  ->             let tgt = Just $ TEnemy im (bpos m)             in modifyClient $ updateTarget leader (const tgt)@@ -545,7 +539,6 @@  endTargetingMsg :: MonadClientUI m => m () endTargetingMsg = do-  Kind.COps{coactor} <- getsState scops   leader <- getLeaderUI   pbody <- getsState $ getActorBody leader   target <- getsClient $ getTarget leader@@ -555,7 +548,7 @@                     Just (TEnemy a _ll) ->                       if memActor a (blid pbody) s                       -- Never equal to leader, hence @partActor@.-                      then partActor coactor $ getActorBody a s+                      then partActor $ getActorBody a s                       else "a fear of the past"                     Just (TPos tpos) ->                       MU.Text $ "position" <+> showPoint lxsize tpos
Game/LambdaHack/Client/HumanSem.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Semantics of human player commands. module Game.LambdaHack.Client.HumanSem   ( cmdHumanSem@@ -6,11 +5,9 @@  import Control.Monad import Control.Monad.Writer.Strict (WriterT)-import qualified Data.EnumMap.Strict as EM import Data.Maybe  import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.Draw import Game.LambdaHack.Client.HumanCmd import Game.LambdaHack.Client.HumanGlobal import Game.LambdaHack.Client.HumanLocal@@ -18,14 +15,9 @@ import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Common.VectorXY import Game.LambdaHack.Utils.Assert@@ -46,15 +38,15 @@ cmdAction :: (MonadClientAbort m, MonadClientUI m)           => HumanCmd -> WriterT Slideshow m (Maybe CmdSer) cmdAction cmd = case cmd of-  Move v -> moveHuman v-  Run v -> runHuman v-  Wait -> fmap Just waitHuman-  Pickup -> fmap Just pickupHuman-  Drop -> fmap Just dropHuman+  Move v -> moveRunHuman False v+  Run v -> moveRunHuman True v+  Wait -> fmap (Just . TakeTimeSer) waitHuman+  Pickup -> fmap (Just . TakeTimeSer) pickupHuman+  Drop -> fmap (Just . TakeTimeSer) dropHuman   Project ts -> projectHuman ts-  Apply ts -> fmap Just $ applyHuman ts-  TriggerDir ts -> fmap Just $ triggerDirHuman ts-  TriggerTile ts -> fmap Just $ triggerTileHuman ts+  Apply ts -> fmap (Just . TakeTimeSer) $ applyHuman ts+  AlterDir ts -> fmap (Just . TakeTimeSer) $ alterDirHuman ts+  TriggerTile ts -> fmap (Just . TakeTimeSer) $ triggerTileHuman ts    GameRestart t -> fmap Just $ gameRestartHuman t   GameExit -> fmap Just gameExitHuman@@ -86,61 +78,46 @@   when (arena /= lid) $     abortWith "[targeting] command disabled on a remote level, press ESC to switch back" -moveHuman :: (MonadClientAbort m, MonadClientUI m)-          => VectorXY -> WriterT Slideshow m (Maybe CmdSer)-moveHuman v = do-  Kind.COps{cotile} <- getsState scops+moveRunHuman :: (MonadClientAbort m, MonadClientUI m)+             => Bool -> VectorXY -> WriterT Slideshow m (Maybe CmdSer)+moveRunHuman run v = do   tgtMode <- getsClient stgtMode-  (arena, lvl@Level{lxsize}) <- viewedLevel-  leader <- getLeaderUI-  sb <- getsState $ getActorBody leader+  (arena, Level{lxsize}) <- viewedLevel+  source <- getLeaderUI+  sb <- getsState $ getActorBody source+  let dir = toDir lxsize v   if isJust tgtMode then do-    let dir = toDir lxsize v-    moveCursor dir 1 >> return Nothing+    moveCursor dir (if run then 10 else 1) >> return Nothing   else do-    let dir = toDir lxsize v-        tpos = bpos sb `shift` dir-        t = lvl `at` tpos-    -- We always see actors from our own faction.+    let tpos = bpos sb `shift` dir+    -- We start by checking actors at the the target position,+    -- which gives a partial information (actors can be invisible),+    -- as opposed to accessibility (and items) which are always accurate+    -- (tiles can't be invisible).     tgt <- getsState $ posToActor tpos arena     case tgt of+      Nothing -> do  -- move or search or alter+        when run $ modifyClient $ \cli -> cli {srunning = Just (dir, 1)}+        fmap (Just . TakeTimeSer) $ moveRunAid source dir+        -- When running, the invisible actor is hit (not displaced!),+        -- so that running in the presence of roving invisible+        -- actors is equivalent to moving (with visible actors+        -- this is not a problem, since runnning stops early enough).+        -- TODO: stop running at invisible actor+      Just target | run ->+        -- Displacing requires accessibility, but it's checked later on.+        fmap (Just . TakeTimeSer) $ displaceAid source target       Just target -> do         tb <- getsState $ getActorBody target-        sfact <- getsState $ (EM.! bfid sb) . sfactionD+        -- We always see actors from our own faction.         if bfid tb == bfid sb && not (bproj tb) then do           -- Select adjacent actor by bumping into him. Takes no time.           success <- selectLeader target-          assert (success `blame` (leader, target, tb)) skip+          assert (success `blame` "bump self" `with` (source, target, tb)) skip           return Nothing-        else do-          unless (bproj tb || isAtWar sfact (bfid tb)) $ do-            go <- displayYesNo ColorBW-                    "This attack will start a war. Are you sure?"-            unless go $ abortWith "Attack canceled."-          when (not (bproj tb) && isAllied sfact (bfid tb)) $ do-            go <- displayYesNo ColorBW-                    "You are bound by an alliance. Really attack?"-            unless go $ abortWith "Attack canceled."-          fmap Just $ moveLeader dir-      _ -> fmap Just $-        if Tile.hasFeature cotile F.Suspect t-           || Tile.hasFeature cotile F.Openable t-        then -- Explore, because the suspect feature is not yet revealed-             -- or because we want to act on the feature.-             exploreLeader dir-        else -- Don't explore, because the suspect feature is known boring.-             moveLeader dir--runHuman :: MonadClientUI m => VectorXY -> WriterT Slideshow m (Maybe CmdSer)-runHuman v = do-  tgtMode <- getsClient stgtMode-  (_, Level{lxsize}) <- viewedLevel-  if isJust tgtMode then-    let dir = toDir lxsize v-    in moveCursor dir 10 >> return Nothing-  else-    let dir = toDir lxsize v-    in fmap Just $ runLeader dir+        else+          -- Attacking does not require full access, adjacency is enough.+          fmap (Just . TakeTimeSer) $ meleeAid source target  projectHuman :: (MonadClientAbort m, MonadClientUI m)              => [Trigger] -> WriterT Slideshow m (Maybe CmdSer)@@ -148,7 +125,9 @@   tgtLoc <- targetToPos   if isNothing tgtLoc     then retargetLeader >> return Nothing-    else fmap Just $ projectLeader ts+    else do+      leader <- getLeaderUI+      fmap (Just . TakeTimeSer) $ projectAid leader ts  tgtFloorHuman :: MonadClientUI m => WriterT Slideshow m (Maybe CmdSer) tgtFloorHuman = do
Game/LambdaHack/Client/LoopAction.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} -- | The main loop of the client, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Client.LoopAction (loopAI, loopUI) where@@ -9,41 +9,48 @@ import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action+import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.ClientCmd+import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Utils.Assert -initCli :: MonadClient m => (State -> m ()) -> m (Either Msg Msg)-initCli putSt = do+initCli :: MonadClient m => DebugModeCli -> (State -> m ()) -> m Bool+initCli sdebugCli putSt = do   -- Warning: state and client state are invalid here, e.g., sdungeon   -- and sper are empty.   cops <- getsState scops+  modifyClient $ \cli -> cli {sdebugCli}   restored <- restoreGame   case restored of-    Left (s, cli, msg) -> do  -- Restore a game or at least history.+    Just (s, cli) | not $ snewGameCli sdebugCli -> do  -- Restore the game.       let sCops = updateCOps (const cops) s       putSt sCops-      putClient cli-      return $ Left msg-    Right msg ->  -- First visit ever, use the initial state.-      return $ Right msg+      putClient cli {sdebugCli}+      return True+    _ ->  -- First visit ever, use the initial state.+      return False -loopAI :: (MonadConnClient CmdClientAI m)-       => (CmdClientAI -> m ()) -> m ()-loopAI cmdClientAISem = do+loopAI :: (MonadClientReadServer CmdClientAI m)+       => DebugModeCli -> (CmdClientAI -> m ()) -> m ()+loopAI sdebugCli cmdClientAISem = do   side <- getsClient sside-  ConnServer{readConnServer} <- getConn-  msg <- initCli $ \s -> cmdClientAISem $ CmdAtomicAI $ ResumeServerA s-  cmd1 <- readConnServer-  case (msg, cmd1) of-    (Left _, CmdAtomicAI ResumeA{}) -> return ()-    (Left _, CmdAtomicAI RestartA{}) -> return ()  -- server savefile faulty-    (Right msg1, CmdAtomicAI ResumeA{}) ->-      error $ T.unpack $ "Savefile of client " <> showT side <> " not usable. Can't join the party. Please remove all savefiles manually and restart. Savefile subsystem said: " <> msg1-    (Right _, CmdAtomicAI RestartA{}) -> return ()-    _ -> assert `failure` (side, msg, cmd1)+  restored <- initCli sdebugCli+              $ \s -> cmdClientAISem $ CmdAtomicAI $ ResumeServerA s+  cmd1 <- readServer+  case (restored, cmd1) of+    (True, CmdAtomicAI ResumeA{}) -> return ()+    (True, CmdAtomicAI RestartA{}) -> return ()  -- ignoring old savefile+    (False, CmdAtomicAI ResumeA{}) -> do+      removeServerSave+      error $ T.unpack $+        "Savefile of client" <+> showT side+        <+> "not usable. Removing server savefile. Please restart now."+    (False, CmdAtomicAI RestartA{}) -> return ()+    _ -> assert `failure` "unexpected command" `with` (side, restored, cmd1)   cmdClientAISem cmd1   -- State and client state now valid.   debugPrint $ "AI client" <+> showT side <+> "started."@@ -51,40 +58,46 @@   debugPrint $ "AI client" <+> showT side <+> "stopped."  where   loop = do-    ConnServer{readConnServer} <- getConn-    cmd <- readConnServer+    cmd <- readServer     cmdClientAISem cmd     quit <- getsClient squit     unless quit loop -loopUI :: (MonadClientUI m, MonadConnClient CmdClientUI m)-       => (CmdClientUI -> m ()) -> m ()-loopUI cmdClientUISem = do+loopUI :: (MonadClientUI m, MonadClientReadServer CmdClientUI m)+       => DebugModeCli -> (CmdClientUI -> m ()) -> m ()+loopUI sdebugCli cmdClientUISem = do+  Kind.COps{corule} <- getsState scops+  let title = rtitle $ Kind.stdRuleset corule   side <- getsClient sside-  ConnServer{readConnServer} <- getConn-  msg <- initCli $ \s -> cmdClientUISem $ CmdAtomicUI $ ResumeServerA s-  cmd1 <- readConnServer-  case (msg, cmd1) of-    (Left msg1, CmdAtomicUI ResumeA{}) -> do+  restored <- initCli sdebugCli+              $ \s -> cmdClientUISem $ CmdAtomicUI $ ResumeServerA s+  cmd1 <- readServer+  case (restored, cmd1) of+    (True, CmdAtomicUI ResumeA{}) -> do+      let msg = "Welcome back to" <+> title <> "."       cmdClientUISem cmd1-      msgAdd msg1-    (Left _, CmdAtomicUI RestartA{}) -> do+      msgAdd msg+    (True, CmdAtomicUI RestartA{}) -> do+      let msg = "Starting a new" <+> title <+> "game."  -- ignore old savefile       cmdClientUISem cmd1-      msgAdd "Starting a new game (and ignoring an old client savefile)."-    (Right msg1, CmdAtomicUI ResumeA{}) ->-      error $ T.unpack $ "Savefile of client " <> showT side <> " not usable. Can't join the party. Please remove all savefiles manually and restart. Savefile subsystem said: " <> msg1-    (Right msg1, CmdAtomicUI RestartA{}) -> do+      msgAdd msg+    (False, CmdAtomicUI ResumeA{}) -> do+      removeServerSave+      error $ T.unpack $+        "Savefile of client" <+> showT side+        <+> "not usable. Removing server savefile. Please restart now."+    (False, CmdAtomicUI RestartA{}) -> do+      let msg = "Welcome to" <+> title <> "!"       cmdClientUISem cmd1-      msgAdd msg1-    _ -> assert `failure` (side, msg, cmd1)+      msgAdd msg+    _ -> assert `failure` "unexpected command" `with` (side, restored, cmd1)   -- State and client state now valid.   debugPrint $ "UI client" <+> showT side <+> "started."   loop   debugPrint $ "UI client" <+> showT side <+> "stopped."  where   loop = do-    ConnServer{readConnServer} <- getConn-    cmd <- readConnServer+    cmd <- readServer     cmdClientUISem cmd     quit <- getsClient squit     unless quit loop
Game/LambdaHack/Client/RunAction.hs view
@@ -1,6 +1,6 @@ -- | Running and disturbance. module Game.LambdaHack.Client.RunAction-  ( canRun, continueRunDir+  ( continueRunDir   ) where  import qualified Data.ByteString.Char8 as BS@@ -25,6 +25,7 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Utils.Assert  -- | Start running in the given direction and with the given number@@ -36,9 +37,10 @@ canRun leader (dir, dist) = do   cops <- getsState scops   b <- getsState $ getActorBody leader-  lvl <- getsLevel (blid b) id+  lvl <- getLevel $ blid b   stgtMode <- getsClient stgtMode-  assert (isNothing stgtMode `blame` (dir, dist, stgtMode)) skip+  assert (isNothing stgtMode `blame` "attempt to run in target mode"+                             `with` (dir, dist, stgtMode)) skip   return $ accessibleDir cops lvl (bpos b) dir  runDir :: MonadClient m => ActorId -> (Vector, Int) -> m (Vector, Int)@@ -50,10 +52,10 @@  -- | Human running mode, determined from the nearby cave layout. data RunMode =-    RunOpen                     -- ^ open space, in particular the T crossing-  | RunHub                      -- ^ a hub of separate corridors-  | RunCorridor (Vector, Bool)  -- ^ a single corridor, turning here or not-  | RunDeadEnd                  -- ^ dead end+    RunOpen                      -- ^ open space, in particular the T crossing+  | RunHub                       -- ^ a hub of separate corridors+  | RunCorridor !(Vector, Bool)  -- ^ a single corridor, turning here or not+  | RunDeadEnd                   -- ^ dead end  -- | Determine the running mode. For corridors, pick the running direction -- trying to explore all corners, by prefering cardinal to diagonal moves.@@ -72,7 +74,7 @@         in L.foldr f []       dirsEnterable = L.filter (dirEnterable pos) (moves lxsize)   in case dirsEnterable of-    [] -> assert `failure` (pos, dir)+    [] -> assert `failure` "actor is stuck" `with` (pos, dir)  -- TODO     [negdir] -> assert (negdir == neg dir) RunDeadEnd     _ ->       let dirsOpen = findOpen dirsEnterable@@ -91,12 +93,13 @@ -- | Check for disturbances to running such as newly visible items, monsters. runDisturbance :: Point -> Int -> Report                -> [Actor] -> [Actor] -> Perception -> Bool -> Point-               -> (F.Feature -> Point -> Bool) -> (Point -> Bool) -> X -> Y+               -> (F.Feature -> Point -> Bool) -> (Point -> Bool)+               -> Kind.Ops TileKind -> Level -> X -> Y                -> (Vector, Int) -> Maybe (Vector, Int) runDisturbance posLast distLast report hs ms per markSuspect posHere-               posHasFeature posHasItems lxsize lysize (dirNew, distNew) =-  let boringMsgs = map BS.pack [ "Saving backup."-                               , "You hear some noises." ]+               posHasFeature posHasItems+               cotile lvl lxsize lysize (dirNew, distNew) =+  let boringMsgs = map BS.pack [ "You hear some noises." ]       -- TODO: use a regexp from the UI config instead       msgShown  = isJust $ findInReport (`notElem` boringMsgs) report       msposs    = ES.delete posHere $ ES.fromList (L.map bpos ms)@@ -134,7 +137,7 @@       touchExplore fun = touchNew fun == [posThere]       touchStop fun = touchNew fun /= []       standNew fun = L.filter (\pos -> posHasFeature F.Walkable pos ||-                                       posHasFeature F.Openable pos)+                                       Tile.openable cotile (lvl `at` pos))                        (touchNew fun)       standExplore fun = not (fun posHere) && standNew fun == [posThere]       standStop fun = not (fun posHere) && standNew fun /= []@@ -172,7 +175,7 @@   fact <- getsState $ (EM.! bfid body) . sfactionD   ms <- getsState $ actorList (isAtWar fact) lid   hs <- getsState $ actorList (not . isAtWar fact) lid-  lvl@Level{lxsize, lysize} <- getsLevel (blid body) id+  lvl@Level{lxsize, lysize} <- getLevel $ blid body   let posHere = bpos body       posHasFeature f pos = Tile.hasFeature cotile f (lvl `at` pos)       posHasItems pos = not $ EM.null $ lvl `atI` pos@@ -183,12 +186,11 @@           maybe abort (runDir leader) $             runDisturbance               posLast distLast sreport hs ms per smarkSuspect posHere-              posHasFeature posHasItems lxsize lysize (dir, distNew)+              posHasFeature posHasItems cotile lvl lxsize lysize (dir, distNew)         | otherwise = abort  -- do not open doors in the middle of a run       tryRun dir = tryRunDist (dir, distLast)       _tryRunAndStop dir = tryRunDist (dir, 1000)-      openableDir pos dir = Tile.hasFeature cotile F.Openable-                              (lvl `at` (pos `shift` dir))+      openableDir pos dir = Tile.openable cotile (lvl `at` (pos `shift` dir))       dirEnterable pos d = accessibleDir cops lvl pos d || openableDir pos d   case runMode posHere dirLast dirEnterable lxsize of     RunDeadEnd -> abort                   -- we don't run backwards
Game/LambdaHack/Client/State.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Server and client game state types and operations. module Game.LambdaHack.Client.State   ( StateClient(..), defStateClient, defHistory@@ -19,6 +18,7 @@ import Game.LambdaHack.Client.Config import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item@@ -57,22 +57,22 @@   , smarkVision  :: !Bool          -- ^ mark leader and party FOV   , smarkSmell   :: !Bool          -- ^ mark smell, if the leader can smell   , smarkSuspect :: !Bool          -- ^ mark suspect features-  , sdebugCli    :: !Bool          -- ^ show client debug messages+  , sdebugCli    :: !DebugModeCli  -- ^ client debugging mode   }   deriving (Show)  -- | Current targeting mode of a client. data TgtMode =     TgtExplicit { tgtLevelId :: !LevelId }-            -- ^ the player requested targeting mode explicitly+      -- ^ the player requested targeting mode explicitly   | TgtAuto     { tgtLevelId :: !LevelId }-            -- ^ the mode was entered (and will be exited) automatically+      -- ^ the mode was entered (and will be exited) automatically   deriving (Show, Eq)  -- | The type of na actor target. data Target =-    TEnemy ActorId Point  -- ^ target an actor with its last seen position-  | TPos Point            -- ^ target a given position+    TEnemy !ActorId !Point  -- ^ target an actor with its last seen position+  | TPos !Point             -- ^ target a given position   deriving (Show, Eq)  -- | Initial game client state.@@ -100,7 +100,7 @@     , smarkVision = False     , smarkSmell = False     , smarkSuspect = False-    , sdebugCli = False+    , sdebugCli = defDebugModeCli     }  defHistory :: IO History@@ -124,7 +124,8 @@ updateLeader leader s cli =   let side1 = bfid $ getActorBody leader s       side2 = sside cli-  in assert (side1 == side2 `blame` (side1, side2, leader, s))+  in assert (side1 == side2 `blame` "enemy actor becomes our leader"+                            `with` (side1, side2, leader, s))      $ cli {_sleader = Just leader}  sside :: StateClient -> FactionId
Game/LambdaHack/Client/Strategy.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFoldable, DeriveTraversable #-} -- | AI strategies to direct actors not controlled directly by human players. -- No operation in this module involves the 'State' or 'Action' type. module Game.LambdaHack.Client.Strategy@@ -7,15 +7,17 @@   ) where  import Control.Monad+import Data.Foldable (Foldable) import Data.Text (Text)+import Data.Traversable (Traversable)  import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Utils.Frequency+import Game.LambdaHack.Utils.Frequency as Frequency  -- | A strategy is a choice of (non-empty) frequency tables -- of possible actions. newtype Strategy a = Strategy { runStrategy :: [Frequency a] }-  deriving Show+  deriving (Show, Foldable, Traversable)  -- | Strategy is a monad. TODO: Can we write this as a monad transformer? instance Monad Strategy where@@ -32,6 +34,9 @@ instance MonadPlus Strategy where   mzero = Strategy []   mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)++instance Functor Strategy where+  fmap f (Strategy fs) = Strategy (map (fmap f) fs)  normalizeStrategy :: Strategy a -> Strategy a normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs
Game/LambdaHack/Client/StrategyAction.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | AI strategy operations implemented with the 'Action' monad. module Game.LambdaHack.Client.StrategyAction   ( targetStrategy, actionStrategy, visibleFoes@@ -9,6 +8,7 @@ import Data.Function import Data.List import Data.Maybe+import qualified Data.Traversable as Traversable  import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.State@@ -26,6 +26,7 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.Random as Random import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile@@ -34,48 +35,48 @@ import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind as TileKind import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.Frequency --- TODO: express many (all?) functions as MonadActionRO- -- | AI proposes possible targets for the actor. Never empty. targetStrategy :: MonadClient m-               => ActorId -> [Ability]-               -> m (Strategy (Maybe Target))-targetStrategy actor factionAbilities = do-  btarget <- getsClient $ getTarget actor+               => ActorId -> [Ability] -> m (Strategy (Maybe Target))+targetStrategy aid factionAbilities = do+  btarget <- getsClient $ getTarget aid   fper <- getsClient sfper-  reacquireTgt fper actor btarget factionAbilities+  reacquireTgt aid factionAbilities btarget fper  visibleFoes :: MonadActionRO m-            => FactionPers -> ActorId -> m [(ActorId, Actor)]-visibleFoes fper aid = do+            => ActorId -> FactionPers -> m [(ActorId, Actor)]+visibleFoes aid fper = do   b <- getsState $ getActorBody aid   assert (not $ bproj b) skip  -- would work, but is probably a bug   let per = fper EM.! blid b   fact <- getsState $ \s -> sfactionD s EM.! bfid b   foes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b)-  return $! filter (actorSeesLoc per aid . bpos . snd) foes+  return $! filter (actorSeesPos per aid . bpos . snd) foes  reacquireTgt :: MonadActionRO m-             => FactionPers -> ActorId -> Maybe Target -> [Ability]+             => ActorId -> [Ability] -> Maybe Target -> FactionPers              -> m (Strategy (Maybe Target))-reacquireTgt fper aid btarget factionAbilities = do-  cops@Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops+reacquireTgt aid factionAbilities btarget fper = do+  cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops   b <- getsState $ getActorBody aid   assert (not $ bproj b) skip  -- would work, but is probably a bug   lvl@Level{lxsize} <- getsState $ \s -> sdungeon s EM.! blid b-  visFoes <- visibleFoes fper aid+  visFoes <- visibleFoes aid fper   actorD <- getsState sactorD   -- TODO: set distant targets so that monsters behave as if they have   -- a plan. We need pathfinding for that.-  noFoes :: Strategy (Maybe Target) <- getsState $ \s ->-    (Just . TPos . (bpos b `shift`)) `liftM` moveStrategy cops aid s Nothing+  noFoes :: Strategy (Maybe Target) <- do+    s <- getState+    str <- moveStrategy cops aid s Nothing+    return $ (Just . TPos . (bpos b `shift`)) `liftM` str   let per = fper EM.! blid b       mk = okind $ bkind b       actorAbilities = acanDo mk `intersect` factionAbilities-      focused = actorSpeed coactor b <= speedNormal+      focused = bspeed b <= speedNormal                 -- Don't focus on a distant enemy, when you can't chase him.                 -- TODO: or only if another enemy adjacent? consider Flee?                 && Ability.Chase `elem` actorAbilities@@ -96,7 +97,7 @@         case tgt of           Just (TEnemy a ll) | focused ->  -- chase even if enemy dead, to loot             case fmap bpos $ EM.lookup a actorD of-              Just l | actorSeesLoc per aid l ->+              Just l | actorSeesPos per aid l ->                 -- prefer visible (and alive) foes                 returN "TEnemy" $ Just $ TEnemy a l               _ -> if null visFoes         -- prefer visible foes to positions@@ -106,7 +107,8 @@                    else closest           Just TEnemy{} -> closest         -- just pick the closest foe           Just (TPos pos) | bpos b == pos -> closest  -- already reached pos-          Just (TPos pos) | not $ bumpableHere cops lvl False pos ->+          Just (TPos pos)+            | not $ bumpableHere cops lvl False (asight mk) pos ->             closest  -- no longer bumpable, even assuming no foes           Just TPos{} | null visFoes -> returN "TPos" tgt                                            -- nothing visible, go to pos@@ -116,180 +118,243 @@  -- | AI strategy based on actor's sight, smell, intelligence, etc. Never empty. actionStrategy :: MonadClient m-               => ActorId -> [Ability]-               -> m (Strategy CmdSer)-actionStrategy actor factionAbilities = do-  cops <- getsState scops-  s <- getState-  btarget <- getsClient $ getTarget actor+               => ActorId -> [Ability] -> m (Strategy CmdSerTakeTime)+actionStrategy aid factionAbilities = do   disco <- getsClient sdisco-  return $! proposeAction cops actor btarget disco s factionAbilities+  btarget <- getsClient $ getTarget aid+  proposeAction disco aid factionAbilities btarget -proposeAction :: Kind.COps -> ActorId-              -> Maybe Target -> Discovery -> State -> [Ability]-              -> Strategy CmdSer-proposeAction cops actor btarget disco s factionAbilities =-  sumS prefix .| combineDistant distant .| sumS suffix-  .| waitBlockNow actor  -- wait until friends sidestep, ensures never empty- where-  Kind.COps{coactor=Kind.Ops{okind}} = cops-  Actor{bkind, bpos} = getActorBody actor s-  (fpos, foeVisible) =-    case btarget of-      Just (TEnemy _ l) -> (l, True)-      Just (TPos l) -> (l, False)-      Nothing -> (bpos, False)  -- an actor blocked by friends or a missile-  combineDistant as = liftFrequency $ sumF as-  -- TODO: Ranged and Tools should only be triggered in some situations.-  aFrequency :: Ability -> Frequency CmdSer-  aFrequency Ability.Ranged = if foeVisible-                              then rangedFreq cops actor disco s fpos-                              else mzero-  aFrequency Ability.Tools  = if foeVisible-                              then toolsFreq cops actor disco s-                              else mzero-  aFrequency Ability.Chase  = if fpos /= bpos-                              then chaseFreq-                              else mzero-  aFrequency _              = assert `failure` distant-  chaseFreq =-    scaleFreq 30 $ bestVariant $ chase cops actor s (fpos, foeVisible)-  aStrategy :: Ability -> Strategy CmdSer-  aStrategy Ability.Track  = track cops actor s-  aStrategy Ability.Heal   = mzero  -- TODO-  aStrategy Ability.Flee   = mzero  -- TODO-  aStrategy Ability.Melee  = foeVisible .=> melee actor s fpos-  aStrategy Ability.Pickup = not foeVisible .=> pickup actor s-  aStrategy Ability.Wander = wander cops actor s-  aStrategy _              = assert `failure` actorAbilities-  actorAbilities = acanDo (okind bkind) `intersect` factionAbilities-  isDistant = (`elem` [Ability.Ranged, Ability.Tools, Ability.Chase])-  (prefix, rest)    = break isDistant actorAbilities-  (distant, suffix) = partition isDistant rest-  sumS = msum . map aStrategy-  sumF = msum . map aFrequency+proposeAction :: MonadActionRO m+              => Discovery -> ActorId -> [Ability] -> Maybe Target+              -> m (Strategy CmdSerTakeTime)+proposeAction disco aid factionAbilities btarget = do+  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops+  Actor{bkind, bpos, blid} <- getsState $ getActorBody aid+  lvl <- getLevel blid+  let mk = okind bkind+      (fpos, mfAid) =+        case btarget of+          Just (TEnemy foeAid l) -> (l, Just foeAid)+          Just (TPos l) -> (l, Nothing)+          Nothing -> (bpos, Nothing)  -- an actor blocked by friends or a missile+      foeVisible = isJust mfAid+      lootHere x = not $ EM.null $ lvl `atI` x+      actorAbilities = acanDo mk `intersect` factionAbilities+      isDistant = (`elem` [ Ability.Trigger+                          , Ability.Ranged+                          , Ability.Tools+                          , Ability.Chase ])+      -- TODO: this is too fragile --- depends on order of abilities+      (prefix, rest)    = break isDistant actorAbilities+      (distant, suffix) = partition isDistant rest+      -- TODO: Ranged and Tools should only be triggered in some situations.+      aFrequency :: MonadActionRO m => Ability -> m (Frequency CmdSerTakeTime)+      aFrequency Ability.Trigger = if foeVisible then return mzero+                                   else triggerFreq aid+      aFrequency Ability.Ranged = if not foeVisible then return mzero+                                  else rangedFreq disco aid fpos+      aFrequency Ability.Tools  = if not foeVisible then return mzero+                                  else toolsFreq disco aid+      aFrequency Ability.Chase  = if fpos == bpos then return mzero+                                  else chaseFreq+      aFrequency ab             = assert `failure` "unexpected ability"+                                          `with` (ab, distant, actorAbilities)+      chaseFreq :: MonadActionRO m => m (Frequency CmdSerTakeTime)+      chaseFreq = do+        st <- chase aid (fpos, foeVisible)+        return $ scaleFreq 30 $ bestVariant st+      aStrategy :: MonadActionRO m => Ability -> m (Strategy CmdSerTakeTime)+      aStrategy Ability.Track  = track aid+      aStrategy Ability.Heal   = return mzero  -- TODO+      aStrategy Ability.Flee   = return mzero  -- TODO+      aStrategy Ability.Melee | Just foeAid <- mfAid = melee aid fpos foeAid+      aStrategy Ability.Melee  = return mzero+      aStrategy Ability.Pickup | not foeVisible && lootHere bpos = pickup aid+      aStrategy Ability.Pickup = return mzero+      aStrategy Ability.Wander = wander aid+      aStrategy ab             = assert `failure` "unexpected ability"+                                        `with`(ab, actorAbilities)+      sumS abis = do+        fs <- mapM aStrategy abis+        return $ msum fs+      sumF abis = do+        fs <- mapM aFrequency abis+        return $ msum fs+      combineDistant as = fmap liftFrequency $ sumF as+  sumPrefix <- sumS prefix+  comDistant <- combineDistant distant+  sumSuffix <- sumS suffix+  return $ sumPrefix .| comDistant .| sumSuffix+           -- Wait until friends sidestep; ensures the strategy is never empty.+           -- TODO: try to switch leader away before that (we already+           -- switch him afterwards)+           .| waitBlockNow aid  -- | A strategy to always just wait.-waitBlockNow :: ActorId -> Strategy CmdSer-waitBlockNow actor = returN "wait" $ WaitSer actor+waitBlockNow :: ActorId -> Strategy CmdSerTakeTime+waitBlockNow aid = returN "wait" $ WaitSer aid  -- | Strategy for dumb missiles.-track :: Kind.COps -> ActorId -> State -> Strategy CmdSer-track cops actor s =-  strat- where-  lvl = sdungeon s EM.! blid-  b@Actor{bpos, bpath, blid} = getActorBody actor s-  clearPath = returN "ClearPathSer" $ SetPathSer actor []-  strat = case bpath of-    Just [] -> assert `failure` (actor, b, s)-    -- TODO: instead let server do this in MoveSer, abort and handle in loop:-    Just (d : _) | not $ accessibleDir cops lvl bpos d -> clearPath-    Just lv -> returN "SetPathSer" $ SetPathSer actor lv-    Nothing -> reject+track :: MonadActionRO m => ActorId -> m (Strategy CmdSerTakeTime)+track aid = do+  cops <- getsState scops+  b@Actor{bpos, bpath, blid} <- getsState $ getActorBody aid+  lvl <- getLevel blid+  let clearPath = returN "ClearPathSer" $ SetPathSer aid []+      strat = case bpath of+        Nothing -> reject+        Just [] -> assert `failure` "null path" `with` (aid, b)+        -- TODO: instead let server do this in MoveSer, abort, handle in loop+        Just (d : _) | not $ accessibleDir cops lvl bpos d -> clearPath+        Just lv -> returN "SetPathSer" $ SetPathSer aid lv+  return strat -pickup :: ActorId -> State -> Strategy CmdSer-pickup actor s =-  lootHere bpos .=> actionPickup- where-  lvl = sdungeon s EM.! blid-  body@Actor{bpos, blid} = getActorBody actor s-  lootHere x = not $ EM.null $ lvl `atI` x-  actionPickup = case EM.minViewWithKey $ lvl `atI` bpos of-    Nothing -> assert `failure` (actor, bpos, lvl)-    Just ((iid, k), _) ->  -- pick up first item-      let item = getItemBody iid s-          l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing-      in case assignLetter iid l body of-        Just l2 -> returN "pickup" $ PickupSer actor iid k l2-        Nothing -> returN "pickup" $ WaitSer actor+-- TODO: (most?) animals don't pick up. Everybody else does.+pickup :: MonadActionRO m => ActorId -> m (Strategy CmdSerTakeTime)+pickup aid = do+  body@Actor{bpos, blid} <- getsState $ getActorBody aid+  lvl <- getLevel blid+  actionPickup <- case EM.minViewWithKey $ lvl `atI` bpos of+    Nothing -> assert `failure` "pickup of empty pile" `with` (aid, bpos, lvl)+    Just ((iid, k), _) -> do  -- pick up first item+      item <- getsState $ getItemBody iid+      let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing+      return $ case assignLetter iid l body of+        Just l2 -> returN "pickup" $ PickupSer aid iid k l2+        Nothing -> returN "pickup" $ WaitSer aid  -- TODO+  return actionPickup -melee :: ActorId -> State -> Point -> Strategy CmdSer-melee actor s fpos =-  foeAdjacent .=> returN "melee" (MoveSer actor dir)- where-  Level{lxsize} = sdungeon s EM.! blid-  Actor{bpos, blid} = getActorBody actor s-  foeAdjacent = adjacent lxsize bpos fpos-  dir = displacement bpos fpos+-- Everybody melees in a pinch, even though some prefer ranged attacks.+melee :: MonadActionRO m+      => ActorId -> Point -> ActorId -> m (Strategy CmdSerTakeTime)+melee aid fpos foeAid = do+  Actor{bpos, blid} <- getsState $ getActorBody aid+  Level{lxsize} <- getLevel blid+  let foeAdjacent = adjacent lxsize bpos fpos  -- MeleeDistant+  return $ foeAdjacent .=> returN "melee" (MeleeSer aid foeAid) -rangedFreq :: Kind.COps -> ActorId -> Discovery -> State -> Point-           -> Frequency CmdSer-rangedFreq cops actor disco s fpos =-  toFreq "throwFreq" $+-- Fast monsters don't pay enough attention to features.+triggerFreq :: MonadActionRO m+            => ActorId -> m (Frequency CmdSerTakeTime)+triggerFreq aid = do+  cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops+  b@Actor{bpos, blid, bfid, boldpos} <- getsState $ getActorBody aid+  fact <- getsState $ \s -> sfactionD s EM.! bfid+  lvl <- getLevel blid+  let spawn = isSpawnFact cops fact+      t = lvl `at` bpos+      feats = TileKind.tfeature $ okind t+      ben feat = case feat of+        F.Cause Effect.Escape | spawn -> 0  -- spawners lose if they escape+        F.Cause ef -> effectToBenefit cops b ef+        _ -> 0+      benFeat = zip (map ben feats) feats+      -- Probably recently switched levels or was pushed to another level.+      -- Do not repeatedly switch levels or push each other between levels.+      -- Consequently, AI won't dive many levels down with linked staircases.+      -- TODO: beware of stupid monsters that backtrack and so occupy stairs.+      recentlyAscended = bpos == boldpos+      -- Too fast to notice and use features.+      fast = bspeed b > speedNormal+  if recentlyAscended || fast then+    return mzero+  else+    return $ toFreq "triggerFreq" $ [ (benefit, TriggerSer aid (Just feat))+                                    | (benefit, feat) <- benFeat+                                    , benefit > 0 ]++-- Actors require sight to use ranged combat and intelligence to throw+-- or zap anything else than obvious physical missiles.+rangedFreq :: MonadActionRO m+           => Discovery -> ActorId -> Point -> m (Frequency CmdSerTakeTime)+rangedFreq disco aid fpos = do+  cops@Kind.COps{ coactor=Kind.Ops{okind}+                , coitem=Kind.Ops{okind=iokind}+                , corule+                , cotile+                } <- getsState scops+  b@Actor{bkind, bpos, bfid, blid, bbag, binv} <- getsState $ getActorBody aid+  lvl@Level{lxsize, lysize} <- getLevel blid+  let mk = okind bkind+      tis = lvl `atI` bpos+  fact <- getsState $ \s -> sfactionD s EM.! bfid+  foes <- getsState $ actorNotProjList (isAtWar fact) blid+  let foesAdj = foesAdjacent lxsize lysize bpos foes+      posClear pos1 = Tile.hasFeature cotile F.Clear (lvl `at` pos1)+  as <- getsState $ actorList (const True) blid+  -- TODO: also don't throw if any pos on path is visibly not accessible+  -- from previous (and tweak eps in bla to make it accessible).+  -- Also don't throw if target not in range.+  s <- getState+  let eps = 0+      bl = bla lxsize lysize eps bpos fpos  -- TODO:make an arg of projectGroupItem+      permitted = (if aiq mk >= 10 then ritemProject else ritemRanged)+                  $ Kind.stdRuleset corule+      throwFreq bag multi container =+        [ (- benefit * multi,+          ProjectSer aid fpos eps iid (container iid))+        | (iid, i) <- map (\iid -> (iid, getItemBody iid s))+                      $ EM.keys bag+        , let benefit =+                case jkind disco i of+                  Nothing -> -- TODO: (undefined, 0)   --- for now, cheating+                    effectToBenefit cops b (jeffect i)+                  Just _ki ->+                    let _kik = iokind _ki+                        _unneeded = isymbol _kik+                    in effectToBenefit cops b (jeffect i)+        , benefit < 0+        , jsymbol i `elem` permitted ]+  return $ toFreq "throwFreq" $     case bl of       Just (pos1 : _) ->-        if not foesAdj+        if not foesAdj  -- ProjectBlockFoes            && asight mk-           && accessible cops lvl bpos pos1       -- first accessible-           && isNothing (posToActor pos1 blid s)  -- no friends on first-        then throwFreq bbag 3 (actorContainer actor binv)+           && posClear pos1  -- ProjectBlockTerrain+           && unoccupied as pos1  -- ProjectBlockActor+        then throwFreq bbag 3 (actorContainer aid binv)              ++ throwFreq tis 6 (const $ CFloor blid bpos)         else []-      _ -> []- where-  Kind.COps{ coactor=Kind.Ops{okind}-           , coitem=Kind.Ops{okind=iokind}-           , corule-           } = cops-  lvl@Level{lxsize, lysize} = sdungeon s EM.! blid-  Actor{bkind, bpos, bfid, blid, bbag, binv} = getActorBody actor s-  mk = okind bkind-  tis = lvl `atI` bpos-  fact = sfactionD s EM.! bfid-  foes = actorNotProjAssocs (isAtWar fact) blid s-  foesAdj = foesAdjacent lxsize lysize bpos (map snd foes)-  -- TODO: also don't throw if any pos on path is visibly not accessible-  -- from previous (and tweak eps in bla to make it accessible).-  -- Also don't throw if target not in range.-  eps = 0-  bl = bla lxsize lysize eps bpos fpos  -- TODO:make an arg of projectGroupItem-  throwFreq bag multi container =-    [ (- benefit * multi,-      ProjectSer actor fpos eps iid (container iid))-    | (iid, i) <- map (\iid -> (iid, getItemBody iid s))-                  $ EM.keys bag-    , let benefit =-            case jkind disco i of-              Nothing -> -- TODO: (undefined, 0)   --- for now, cheating-                Effect.effectToBenefit (jeffect i)-              Just _ki ->-                let _kik = iokind _ki-                    _unneeded = isymbol _kik-                in Effect.effectToBenefit (jeffect i)-    , benefit < 0-      -- Wasting weapons and armour would be too cruel to the player.-    , jsymbol i `elem` ritemProject (Kind.stdRuleset corule) ]+      _ -> []  -- ProjectAimOnself -toolsFreq :: Kind.COps -> ActorId -> Discovery -> State -> Frequency CmdSer-toolsFreq cops actor disco s =-  toFreq "quaffFreq"-  $ quaffFreq bbag 1 (actorContainer actor binv)-  ++ quaffFreq tis 2 (const $ CFloor blid bpos)- where-  Kind.COps{coitem=Kind.Ops{okind=_iokind}} = cops-  Actor{bpos, blid, bbag, binv} = getActorBody actor s-  lvl = sdungeon s EM.! blid-  tis = lvl `atI` bpos-  quaffFreq bag multi container =-    [ (benefit * multi, ApplySer actor iid (container iid))-    | (iid, i) <- map (\iid -> (iid, getItemBody iid s))-                  $ EM.keys bag-    , let benefit =-            case jkind disco i of-              Nothing -> 30  -- experimenting is fun-              Just _ki -> Effect.effectToBenefit $ jeffect i-    , benefit > 0-    , jsymbol i == '!' ]+-- Tools use requires significant intelligence and sometimes literacy.+toolsFreq :: MonadActionRO m+          => Discovery -> ActorId -> m (Frequency CmdSerTakeTime)+toolsFreq disco aid = do+  cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops+  b@Actor{bkind, bpos, blid, bbag, binv} <- getsState $ getActorBody aid+  lvl <- getLevel blid+  s <- getState+  let tis = lvl `atI` bpos+      mk = okind bkind+      mastered | aiq mk < 5 = ""+               | aiq mk < 10 = "!"+               | otherwise = "!?"  -- literacy required+      useFreq bag multi container =+        [ (benefit * multi, ApplySer aid iid (container iid))+        | (iid, i) <- map (\iid -> (iid, getItemBody iid s))+                      $ EM.keys bag+        , let benefit =+                case jkind disco i of+                  Nothing -> 30  -- experimenting is fun+                  Just _ki -> effectToBenefit cops b $ jeffect i+        , benefit > 0+        , jsymbol i `elem` mastered ]+  return $ toFreq "useFreq" $+    useFreq bbag 1 (actorContainer aid binv)+    ++ useFreq tis 2 (const $ CFloor blid bpos) +-- TODO: express fully in MonadActionRO+-- TODO: separate out bumping into solid tiles -- TODO: also close doors; then stupid members of the party won't see them, -- but it's assymetric warfare: rather harm humans than help party members -- | AI finds interesting moves in the absense of visible foes. -- This strategy can be null (e.g., if the actor is blocked by friends).-moveStrategy :: Kind.COps -> ActorId -> State -> Maybe (Point, Bool)-             -> Strategy Vector-moveStrategy cops actor s mFoe =-  case mFoe of+moveStrategy :: MonadActionRO m+             => Kind.COps -> ActorId -> State -> Maybe (Point, Bool)+             -> m (Strategy Vector)+moveStrategy cops aid s mFoe =+  return $ case mFoe of     -- Target set and we chase the foe or his last position or another target.     Just (fpos, _) ->       let towardsFoe =@@ -324,7 +389,7 @@  where   Kind.COps{cotile, coactor=Kind.Ops{okind}} = cops   lvl@Level{lsmell, lxsize, lysize, ltime} = sdungeon s EM.! blid-  Actor{bkind, bpos, boldpos, bfid, blid} = getActorBody actor s+  Actor{bkind, bpos, boldpos, bfid, blid} = getActorBody aid s   mk = okind bkind   lootHere x = not $ EM.null $ lvl `atI` x   onlyLoot = onlyMoves lootHere@@ -344,6 +409,9 @@     only (\x -> maybe True (\d -> euclidDistSq lxsize d x <= k) bdirAI)   onlyKeepsDir_9 = only (\x -> maybe True (\d -> neg x /= d) bdirAI)   foeVisible = fmap snd mFoe == Just True+  -- TODO: aiq 16 leads to robotic, repetitious, looping movement;+  -- either base it off some new stat or wait until pathfinding,+  -- which will eliminate the loops   moveIQ | foeVisible = onlyKeepsDir_9 moveRandomly  -- danger, be flexible          | otherwise =        aiq mk > 15 .=> onlyKeepsDir 0 moveRandomly@@ -355,10 +423,12 @@     mzero                | otherwise =     -- Prefer interests, but don't exclude other focused moves.-    scaleFreq 5 $ bestVariant $ onlyInterest $ onlyKeepsDir 2 moveRandomly+    scaleFreq 10 $ bestVariant $ onlyInterest $ onlyKeepsDir 2 moveRandomly   interestIQFreq = interestFreq `mplus` bestVariant moveIQ-  moveClear    = onlyMoves (not . bumpableHere cops lvl foeVisible) moveFreely-  moveOpenable = onlyMoves (bumpableHere cops lvl foeVisible) moveFreely+  moveClear    =+    onlyMoves (not . bumpableHere cops lvl foeVisible (asight mk)) moveFreely+  moveOpenable =+    onlyMoves (bumpableHere cops lvl foeVisible (asight mk)) moveFreely   -- Ignore previously ignored loot, to prevent repetition.   moveNewLoot = onlyLoot (onlyKeepsDir 2 moveRandomly)   moveFreely = moveNewLoot@@ -374,32 +444,110 @@   friends = actorList (not . isAtWar fact) blid s   noFriends | asight mk = unoccupied friends             | otherwise = const True-  isSensible l = noFriends l && (accessibleHere l-                                 || bumpableHere cops lvl foeVisible l)+  isSensible l = noFriends l+                 && (accessibleHere l+                     || bumpableHere cops lvl foeVisible (asight mk) l)   sensible = filter (isSensible . (bpos `shift`)) (moves lxsize) -bumpableHere :: Kind.COps -> Level -> Bool ->  Point -> Bool-bumpableHere Kind.COps{cotile} lvl foeVisible pos  =-  let t = lvl `at` pos-  in Tile.hasFeature cotile F.Openable t-     || -- Try to find hidden doors only if no foe in sight.-        not foeVisible && Tile.hasFeature cotile F.Suspect t+bumpableHere :: Kind.COps -> Level -> Bool -> Bool -> Point -> Bool+bumpableHere Kind.COps{cotile} lvl foeVisible asight pos =+  let t = lvl `at` pos  -- cannot hold items, so OK+  in Tile.openable cotile t+     || -- Try to find hidden doors only if no foe in sight and not blind.+        -- Blind actors forget their search results too quickly.+        asight && not foeVisible && Tile.hasFeature cotile F.Suspect t -chase :: Kind.COps -> ActorId -> State -> (Point, Bool) -> Strategy CmdSer-chase cops actor s foe@(_, foeVisible) =+chase :: MonadActionRO m+      => ActorId -> (Point, Bool) -> m (Strategy CmdSerTakeTime)+chase aid foe@(_, foeVisible) = do+  cops <- getsState scops   -- Target set and we chase the foe or offer null strategy if we can't.   -- The foe is visible, or we remember his last position.-  -- TODO: explore if a possible secret   let mFoe = Just foe       fight = not foeVisible  -- don't pick fights if the real foe is close-  in if fight-     then ExploreSer actor `liftM` moveStrategy cops actor s mFoe-     else RunSer actor `liftM` moveStrategy cops actor s mFoe+  s <- getState+  str <- moveStrategy cops aid s mFoe+  if fight+    then Traversable.mapM (moveRunAid False aid) str+    else Traversable.mapM (moveRunAid True aid) str -wander :: Kind.COps -> ActorId -> State -> Strategy CmdSer-wander cops actor s =+wander :: MonadActionRO m+       => ActorId -> m (Strategy CmdSerTakeTime)+wander aid = do+  cops <- getsState scops   -- Target set, but we don't chase the foe, e.g., because we are blocked   -- or we cannot chase at all.-  -- TODO: explore if a possible secret   let mFoe = Nothing-  in ExploreSer actor `liftM` moveStrategy cops actor s mFoe+  s <- getState+  str <- moveStrategy cops aid s mFoe+  Traversable.mapM (moveRunAid False aid) str++-- | Actor moves or searches or alters or attacks. Displaces if @run@.+moveRunAid :: MonadActionRO m+           => Bool -> ActorId -> Vector -> m CmdSerTakeTime+moveRunAid run source dir = do+  cops@Kind.COps{cotile} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+  lvl <- getLevel lid+  let spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+      t = lvl `at` tpos+  -- We start by checking actors at the the target position,+  -- which gives a partial information (actors can be invisible),+  -- as opposed to accessibility (and items) which are always accurate+  -- (tiles can't be invisible).+  tgt <- getsState $ posToActor tpos lid+  case tgt of+    Just target | run ->  -- can be a foe, as well as a friend+      if accessible cops lvl spos tpos then+        -- Displacing requires accessibility.+        return $ DisplaceSer source target+      else+        -- If cannot displace, hit. No DisplaceAccess.+        return $ MeleeSer source target+    Just target ->  -- can be a foe, as well as a friend+      -- Attacking does not require full access, adjacency is enough.+      return $ MeleeSer source target+    Nothing -> do  -- move or search or alter+      if accessible cops lvl spos tpos then+        -- Movement requires full access.+        return $ MoveSer source dir+        -- The potential invisible actor is hit.+      else if not $ EM.null $ lvl `atI` tpos then+        -- This is, e.g., inaccessible open door with an item in it.+        assert `failure` "AI causes AlterBlockItem" `with` (run, source, dir)+      else if not (Tile.hasFeature cotile F.Walkable t)  -- not implied+              && (Tile.hasFeature cotile F.Suspect t+                  || Tile.openable cotile t+                  || Tile.closable cotile t+                  || Tile.changeable cotile t) then+        -- No access, so search and/or alter the tile.+        return $ AlterSer source tpos Nothing+      else+        -- Boring tile, no point bumping into it, do WaitSer if really idle.+        assert `failure` "AI causes MoveNothing or AlterNothing"+               `with` (run, source, dir)++-- | How much AI benefits from applying the effect. Multipllied by item p.+-- Negative means harm to the enemy when thrown at him. Effects with zero+-- benefit won't ever be used, neither actively nor passively.+effectToBenefit :: Kind.COps -> Actor -> Effect.Effect Int -> Int+effectToBenefit Kind.COps{coactor=Kind.Ops{okind}} b eff =+  let kind = okind $ bkind b+      deep k = signum k == signum (fromEnum $ blid b)+  in case eff of+    Effect.NoEffect -> 0+    (Effect.Heal p) -> 10 * min p (Random.maxDice (ahp kind) - bhp b)+    (Effect.Hurt _ p) -> -(p * 10)     -- TODO: dice ignored, not capped+    Effect.Mindprobe{} -> 0            -- AI can't benefit yet+    Effect.Dominate -> -100+    (Effect.CallFriend p) -> p * 100+    Effect.Summon{} -> 1               -- may or may not spawn a friendly+    (Effect.CreateItem p) -> p * 20+    Effect.ApplyPerfume -> 0+    Effect.Regeneration{} -> 0         -- bigger benefit from carrying around+    Effect.Searching{} -> 0+    (Effect.Ascend k) | deep k -> 500  -- AI likes to explore deep down+    Effect.Ascend{} -> 1+    Effect.Escape -> 1000              -- AI wants to win
Game/LambdaHack/Common/Ability.hs view
@@ -3,6 +3,8 @@   ( Ability(..)   ) where +import Data.Binary+ -- | All possible AI actor abilities. AI chooses among these when considering -- the next action to perform. The ability descriptions refer to the target -- that any actor picks each turn, depending on the actor's characteristics@@ -13,13 +15,13 @@   | Flee    -- ^ flee if almost dead   | Melee   -- ^ melee target   | Pickup  -- ^ gather items, if no foes visible+  | Trigger -- ^ trigger a feature   | Ranged  -- ^ attack the visible target opponent at range, some of the time   | Tools   -- ^ use items, if target opponent visible, some of the time   | Chase   -- ^ chase the target, ignoring any actors on the way   | Wander  -- ^ wander around, meleeing any opponents on the way   deriving (Show, Eq, Ord, Enum, Bounded) -  -- A note for when we let AI change levels:-  -- A faction that spawns cannot switch levels (nor move between levels).-  -- Otherwise it would constantly go to a distant level, spawn actors there-  -- and swarm any opponent arriving on the level.+instance Binary Ability where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8
Game/LambdaHack/Common/Action.hs view
@@ -1,12 +1,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE OverloadedStrings #-} -- | Game action monads and basic building blocks for human and computer -- player actions. Has no access to the the main action type. module Game.LambdaHack.Common.Action   ( -- * Action monads     MonadActionRO(..), MonadAction(..), MonadAtomic(..)     -- * Shorthands-  , getsLevel, nHumans+  , getLevel, nUI+    -- * Assorted+  , serverSaveName   ) where  import Control.Monad.Writer.Strict (WriterT, lift)@@ -17,6 +18,7 @@ import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind  class (Monad m, Functor m) => MonadActionRO m where   getState    :: m State@@ -40,10 +42,13 @@   execSfxAtomic :: SfxAtomic -> m ()   execSfxAtomic = execAtomic . SfxAtomic -getsLevel :: MonadActionRO m => LevelId -> (Level -> a) -> m a-getsLevel lid f = getsState $ f . (EM.! lid) . sdungeon+getLevel :: MonadActionRO m => LevelId -> m Level+getLevel lid = getsState $ (EM.! lid) . sdungeon -nHumans :: MonadActionRO m => m Int-nHumans = do+nUI :: MonadActionRO m => m Int+nUI = do   factionD <- getsState sfactionD-  return $ length $ filter isHumanFact $ EM.elems factionD+  return $ length $ filter (playerUI . gplayer) $ EM.elems factionD++serverSaveName :: String+serverSaveName = "server.sav"
Game/LambdaHack/Common/Actor.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Actors in the game: heroes, monsters, etc. No operation in this module -- involves the 'State' or 'Action' type. module Game.LambdaHack.Common.Actor   ( -- * Actor identifiers and related operations     ActorId, monsterGenChance, partActor     -- * The@ Acto@r type-  , Actor(..), actorTemplate, timeAddFromSpeed, braced-  , unoccupied, heroKindId, projectileKindId, actorSpeed+  , Actor(..), actorTemplate, timeAddFromSpeed, braced, waitedLastTurn+  , unoccupied, heroKindId, projectileKindId     -- * Inventory management   , ItemBag, ItemInv, InvChar(..), ItemDict, ItemRev   , allLetters, assignLetter, letterLabel, letterRange, rmFromBag@@ -19,7 +18,6 @@ import Data.Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.Hashable as Hashable import qualified Data.HashMap.Strict as HM import Data.List import Data.Maybe@@ -55,10 +53,10 @@ -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor   { bkind   :: !(Kind.Id ActorKind)  -- ^ the kind of the actor-  , bsymbol :: !(Maybe Char)         -- ^ individual map symbol-  , _bname  :: !(Maybe Text)         -- ^ individual name-  , bcolor  :: !(Maybe Color.Color)  -- ^ individual map color-  , bspeed  :: !(Maybe Speed)        -- ^ individual speed+  , bsymbol :: !Char                 -- ^ individual map symbol+  , bname   :: !Text                 -- ^ individual name+  , bcolor  :: !Color.Color          -- ^ individual map color+  , bspeed  :: !Speed                -- ^ individual speed   , bhp     :: !Int                  -- ^ current hit points   , bpath   :: !(Maybe [Vector])     -- ^ path the actor is forced to travel   , bpos    :: !Point                -- ^ current position@@ -82,25 +80,24 @@ -- which monster is generated. How many and which monsters are generated -- will also depend on the cave kind used to build the level. monsterGenChance :: Int -> Int -> Int -> Rnd Bool-monsterGenChance ldepth depth numMonsters =-  -- Mimics @rollDeep@.-  let scaledDepth = 10 * (ldepth - 1) `div` max 1 (depth - 1)+monsterGenChance n' depth' numMonsters =+  -- Mimics @castDeep@.+  let n = abs n'+      depth = abs depth'+      scaledDepth = 10 * (n - 1) `div` max 1 (depth - 1)   in chance $ 1%(fromIntegral (50 * (numMonsters - scaledDepth)) `max` 5)  -- | The part of speech describing the actor.-partActor :: Kind.Ops ActorKind -> Actor -> MU.Part-partActor Kind.Ops{oname} a =-  case _bname a of-    Nothing -> MU.AW $ MU.Text $ oname $ bkind a-    Just properName -> MU.Text properName+partActor :: Actor -> MU.Part+partActor b = MU.Text $ bname b  -- Actor operations  -- | A template for a new non-projectile actor.-actorTemplate :: Kind.Id ActorKind -> Maybe Char -> Maybe Text-              -> Maybe Color.Color -> Maybe Speed -> Int -> Maybe [Vector]+actorTemplate :: Kind.Id ActorKind -> Char -> Text+              -> Color.Color -> Speed -> Int -> Maybe [Vector]               -> Point -> LevelId -> Time -> FactionId -> Bool -> Actor-actorTemplate bkind bsymbol _bname bcolor bspeed bhp bpath bpos blid btime+actorTemplate bkind bsymbol bname bcolor bspeed bhp bpath bpos blid btime               bfid bproj =   let boldpos = bpos       bbag    = EM.empty@@ -109,27 +106,29 @@       bwait   = timeZero   in Actor{..} --- | Access actor speed, individual or, otherwise, stock.-actorSpeed :: Kind.Ops ActorKind -> Actor -> Speed-actorSpeed Kind.Ops{okind} m =-  let stockSpeed = aspeed $ okind $ bkind m-  in fromMaybe stockSpeed $ bspeed m- -- | Add time taken by a single step at the actor's current speed.-timeAddFromSpeed :: Kind.Ops ActorKind -> Actor -> Time -> Time-timeAddFromSpeed coactor m time =-  let speed = actorSpeed coactor m+timeAddFromSpeed :: Actor -> Time -> Time+timeAddFromSpeed b time =+  let speed = bspeed b       delta = ticksPerMeter speed   in timeAdd time delta --- | Whether an actor is braced for combat this turn.+-- | Whether an actor is braced for combat this clip. If a foe+-- moves just after this actor in the same time moment, the actor won't block,+-- because @bwait@ is reset to zero in @ageActorA@ before the condition+-- is checked. braced :: Actor -> Time -> Bool-braced m time = time < bwait m+braced b time = time <= bwait b +-- | The actor most probably waited at most a turn ago (unless his speed+-- was changed, etc.)+waitedLastTurn :: Actor -> Time -> Bool+waitedLastTurn b time = time <= bwait b+ -- | Checks for the presence of actors in a position. -- Does not check if the tile is walkable. unoccupied :: [Actor] -> Point -> Bool-unoccupied actors pos = all (\body -> bpos body /= pos) actors+unoccupied actors pos = all (\b -> bpos b /= pos) actors  -- | The unique kind of heroes. heroKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind@@ -169,11 +168,6 @@ -- in bijection. type ItemRev = HM.HashMap Item ItemId -instance (Binary k, Binary v, Eq k, Hashable.Hashable k)-  => Binary (HM.HashMap k v) where-  put ir = put $ HM.toList ir-  get = fmap HM.fromList get- cmpLetter :: InvChar -> InvChar -> Ordering cmpLetter (InvChar x) (InvChar y) =   compare (isUpper x, toLower x) (isUpper y, toLower y)@@ -222,9 +216,9 @@  rmFromBag :: Int -> ItemId -> ItemBag -> ItemBag rmFromBag k iid bag =-  let rib Nothing = assert `failure` (k, iid, bag)+  let rib Nothing = assert `failure` "rm from empty bag" `with` (k, iid, bag)       rib (Just n) = case compare n k of-        LT -> assert `failure` (n, k, iid, bag)+        LT -> assert `failure` "rm more than there is" `with` (n, k, iid, bag)         EQ -> Nothing         GT -> Just (n - k)   in EM.alter rib iid bag@@ -238,7 +232,7 @@   put Actor{..} = do     put bkind     put bsymbol-    put _bname+    put bname     put bcolor     put bspeed     put bhp@@ -256,7 +250,7 @@   get = do     bkind <- get     bsymbol <- get-    _bname <- get+    bname <- get     bcolor <- get     bspeed <- get     bhp <- get
Game/LambdaHack/Common/ActorState.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Operations on the 'Actor' type that need the 'State' type, -- but not the 'Action' type. -- TODO: Document an export list after it's rewritten according to #17.@@ -59,8 +58,8 @@ posToActor :: Point -> LevelId -> State -> Maybe ActorId posToActor pos lid s =   let l = posToActors pos lid s-  in assert (length l <= 1 `blame` l) $-     listToMaybe l+  in assert (length l <= 1 `blame` "many actors at the same position" `with` l)+     $ listToMaybe l  posToActors :: Point -> LevelId -> State -> [ActorId] posToActors pos lid s =@@ -73,9 +72,10 @@                  -> [Point] nearbyFreePoints cotile f start lid s =   let lvl@Level{lxsize, lysize} = sdungeon s EM.! lid+      as = actorList (const True) lid s       good p = f (lvl `at` p)                && Tile.hasFeature cotile F.Walkable (lvl `at` p)-               && unoccupied (actorList (const True) lid s) p+               && unoccupied as p       ps = nub $ start : concatMap (vicinity lxsize lysize) ps   in filter good ps @@ -117,34 +117,47 @@ tryFindHeroK s fact k =   let c | k == 0          = '@'         | k > 0 && k < 10 = Char.intToDigit k-        | otherwise       = assert `failure` k-  in tryFindActor s (\body -> bsymbol body == Just c+        | otherwise       = assert `failure` "no digit" `with` k+  in tryFindActor s (\body -> bsymbol body == c                               && not (bproj body)                               && bfid body == fact)  -- | Compute the level identifier and starting position on the level, -- after a level change.-whereTo :: State    -- ^ game state-        -> LevelId  -- ^ start from this level-        -> Int      -- ^ jump down this many levels-        -> Maybe (LevelId, Point)+whereTo :: LevelId  -- ^ level of the stairs+        -> Point    -- ^ position of the stairs+        -> Int      -- ^ jump up this many levels+        -> State    -- ^ game state+        -> (LevelId, Point)                     -- ^ target level and the position of its receiving stairs-whereTo s lid k = assert (k /= 0) $-  case ascendInBranch (sdungeon s) lid k of-    [] -> Nothing-    ln : _ -> let lvlTrg = sdungeon s EM.! ln-              in Just (ln, (if k < 0 then fst else snd) (lstair lvlTrg))+whereTo lid pos k s = assert (k /= 0) $+  let dungeon = sdungeon s+      lvl = dungeon EM.! lid+      stairs = (if k < 0 then snd else fst) (lstair lvl)+      defaultStairs = 0  -- for ascending via, e.g., spells+      mindex = elemIndex pos stairs+      i = fromMaybe defaultStairs mindex+  in case ascendInBranch dungeon lid k of+    [] | isNothing mindex -> (lid, pos)  -- spell fizzles+    [] -> assert `failure` "no dungeon level to go to" `with` (lid, pos, k)+    ln : _ -> let lvlTgt = dungeon EM.! ln+                  stairsTgt = (if k < 0 then fst else snd) (lstair lvlTgt)+              in if length stairsTgt < i + 1+                 then assert `failure` "no stairs at index"+                             `with` (lid, pos, k, ln, stairsTgt, i)+                 else (ln, stairsTgt !! i)  -- * The operations below disregard levels other than the current.  -- | Gets actor body from the current level. Error if not found. getActorBody :: ActorId -> State -> Actor getActorBody aid s =-  fromMaybe (assert `failure` (aid, s)) $ EM.lookup aid $ sactorD s+  fromMaybe (assert `failure` "body not found" `with` (aid, s))+  $ EM.lookup aid $ sactorD s  updateActorBody :: ActorId -> (Actor -> Actor) -> State -> State updateActorBody aid f s =-  let alt Nothing = assert `failure` (aid, s)+  let alt Nothing = assert `failure` "no body to update" `with` (aid, s)       alt (Just b) = Just $ f b   in updateActorD (EM.alter alt aid) s @@ -155,7 +168,7 @@ actorContainer aid binv iid =   case find ((== iid) . snd) $ EM.assocs binv of     Just (l, _) -> CActor aid l-    Nothing -> assert `failure` (aid, binv, iid)+    Nothing -> assert `failure` "item not in inventory" `with` (aid, binv, iid)  getActorInv :: ActorId -> State -> ItemInv getActorInv aid s = binv $ getActorBody aid s@@ -169,7 +182,8 @@  getItemBody :: ItemId -> State -> Item getItemBody iid s =-  fromMaybe (assert `failure` (iid, s)) $ EM.lookup iid $ sitemD s+  fromMaybe (assert `failure` "item body not found"+                    `with` (iid, s)) $ EM.lookup iid $ sitemD s  -- | Checks if the actor is present on the current level. -- The order of argument here and in other functions is set to allow
Game/LambdaHack/Common/Animation.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Screen frames and animations. module Game.LambdaHack.Common.Animation   ( Attr(..), defAttr, AttrChar(..)@@ -6,6 +6,7 @@   , Animation, Frames, renderAnim, restrictAnim   , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout   , AcFrame(..)+  , DebugModeCli(..), defDebugModeCli   ) where  import Control.Arrow ((***))@@ -26,6 +27,9 @@ import Game.LambdaHack.Common.Random  -- | The data sufficent to draw a single game screen frame.+--+-- The fields are not strict, because sometimes frames are not used,+-- e.g., when a keypress discards all frames not yet drawn and displayed. data SingleFrame = SingleFrame   { sfLevel  :: [[AttrChar]]  -- ^ content of the screen, line by line   , sfTop    :: Text          -- ^ an extra line to show at the top@@ -109,9 +113,8 @@   , (coloredSymbol c1      '-', blank)   , (coloredSymbol c1      '\\',blank)   , (coloredSymbol c1      '|', blank)-  , (coloredSymbol c2      '/', blank)-  , (coloredSymbol c2      '%', coloredSymbol BrCyan '^')   , (coloredSymbol c2      '%', blank)+  , (coloredSymbol c2      '%', blank)   , (blank                    , blank)   ] @@ -121,9 +124,8 @@   [ (coloredSymbol BrWhite '*', blank)   , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')   , (coloredSymbol BrBlue  '{', blank)-  , (coloredSymbol c1      '}', blank)-  , (coloredSymbol c1      '}', coloredSymbol BrCyan '^')-  , (coloredSymbol c2      '/', blank)+  , (coloredSymbol BrBlue  '}', blank)+  , (coloredSymbol c1      '/', blank)   , (coloredSymbol c2      '%', blank)   , (coloredSymbol c2      '%', blank)   , (blank                    , blank)@@ -133,8 +135,7 @@ blockMiss :: (Point, Point) -> Animation blockMiss poss = Animation $ map (EM.fromList . mzipPairs poss)   [ (coloredSymbol BrWhite '*', blank)-  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')-  , (coloredSymbol BrBlue  '}', blank)+  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '\'')   , (coloredSymbol BrBlue  '}', blank)   , (blank                    , blank)   ]@@ -198,9 +199,9 @@   return $ Animation as  data AcFrame =-    AcConfirm SingleFrame-  | AcRunning SingleFrame-  | AcNormal SingleFrame+    AcConfirm !SingleFrame+  | AcRunning !SingleFrame+  | AcNormal !SingleFrame   | AcDelay   deriving (Show, Eq) @@ -217,3 +218,66 @@       2 -> liftM AcNormal get       3 -> return AcDelay       _ -> fail "no parse (AcFrame)"++data DebugModeCli = DebugModeCli+  { sfont          :: !(Maybe String)+      -- ^ Font to use for the main game window.+  , smaxFps        :: !(Maybe Int)+      -- ^ Maximal frames per second.+      -- This is better low and fixed, to avoid jerkiness and delays+      -- that tell the player there are many intelligent enemies on the level.+      -- That's better than scaling AI sofistication down based+      -- on the FPS setting and machine speed.+  , snoDelay       :: !Bool+      -- ^ Don't maintain any requested delays between frames,+      -- e.g., for screensaver.+  , snoMore        :: !Bool+      -- ^ Auto-answer all prompts, e.g., for screensaver.+  , snoAnim        :: !(Maybe Bool)+      -- ^ Don't show any animations.+  , snewGameCli    :: !Bool+      -- ^ Start a new game, overwriting the save file.+  , ssavePrefixCli :: !(Maybe String)+      -- ^ Prefix of the save game file.+  , sfrontendStd   :: !Bool+      -- ^ Whether to use the stdout/stdin frontend.+  , sdbgMsgCli     :: !Bool+      -- ^ Show clients' internal debug messages.+  }+  deriving (Show, Eq)++defDebugModeCli :: DebugModeCli+defDebugModeCli = DebugModeCli+  { sfont = Nothing+  , smaxFps = Nothing+  , snoDelay = False+  , snoMore = False+  , snoAnim = Nothing+  , snewGameCli = False+  , ssavePrefixCli = Nothing+  , sfrontendStd = False+  , sdbgMsgCli = False+  }++instance Binary DebugModeCli where+  put DebugModeCli{..} = do+    put sfont+    put smaxFps+    put snoDelay+    put snoMore+    put snoAnim+    put snewGameCli+    put ssavePrefixCli+    put sfrontendStd+    put sdbgMsgCli+  get = do+    sfont <- get+    smaxFps <- get+    snoDelay <- get+    snoMore <- get+    snoAnim <- get+    snewGameCli <- get+    ssavePrefixCli <- get+    sfrontendStd <- get+    sdbgMsgCli <- get+    return DebugModeCli{..}
Game/LambdaHack/Common/AtomicCmd.hs view
@@ -22,6 +22,7 @@ import GHC.Generics (Generic)  import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction@@ -39,8 +40,8 @@ import Game.LambdaHack.Content.TileKind as TileKind  data Atomic =-    CmdAtomic CmdAtomic-  | SfxAtomic SfxAtomic+    CmdAtomic !CmdAtomic+  | SfxAtomic !SfxAtomic   deriving (Show, Eq, Generic)  instance Binary Atomic@@ -48,69 +49,69 @@ -- | Abstract syntax of atomic commands. data CmdAtomic =   -- Create/destroy actors and items.-    CreateActorA ActorId Actor [(ItemId, Item)]-  | DestroyActorA ActorId Actor [(ItemId, Item)]-  | CreateItemA ItemId Item Int Container-  | DestroyItemA ItemId Item Int Container-  | SpotActorA ActorId Actor [(ItemId, Item)]-  | LoseActorA ActorId Actor [(ItemId, Item)]-  | SpotItemA ItemId Item Int Container-  | LoseItemA ItemId Item Int Container+    CreateActorA !ActorId !Actor ![(ItemId, Item)]+  | DestroyActorA !ActorId !Actor ![(ItemId, Item)]+  | CreateItemA !ItemId !Item !Int !Container+  | DestroyItemA !ItemId !Item !Int !Container+  | SpotActorA !ActorId !Actor ![(ItemId, Item)]+  | LoseActorA !ActorId !Actor ![(ItemId, Item)]+  | SpotItemA !ItemId !Item !Int !Container+  | LoseItemA !ItemId !Item !Int !Container   -- Move actors and items.-  | MoveActorA ActorId Point Point-  | WaitActorA ActorId Time Time-  | DisplaceActorA ActorId ActorId-  | MoveItemA ItemId Int Container Container+  | MoveActorA !ActorId !Point !Point+  | WaitActorA !ActorId !Time !Time+  | DisplaceActorA !ActorId !ActorId+  | MoveItemA !ItemId !Int !Container !Container   -- Change actor attributes.-  | AgeActorA ActorId Time-  | HealActorA ActorId Int-  | HasteActorA ActorId Speed-  | PathActorA ActorId (Maybe [Vector]) (Maybe [Vector])-  | ColorActorA ActorId (Maybe Color.Color) (Maybe Color.Color)+  | AgeActorA !ActorId !Time+  | HealActorA !ActorId !Int+  | HasteActorA !ActorId !Speed+  | PathActorA !ActorId !(Maybe [Vector]) !(Maybe [Vector])+  | ColorActorA !ActorId !Color.Color !Color.Color   -- Change faction attributes.-  | QuitFactionA FactionId (Maybe Actor) (Maybe Status) (Maybe Status)-  | LeadFactionA FactionId (Maybe ActorId) (Maybe ActorId)-  | DiplFactionA FactionId FactionId Diplomacy Diplomacy+  | QuitFactionA !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status)+  | LeadFactionA !FactionId !(Maybe ActorId) !(Maybe ActorId)+  | DiplFactionA !FactionId !FactionId !Diplomacy !Diplomacy   -- Alter map.-  | AlterTileA LevelId Point (Kind.Id TileKind) (Kind.Id TileKind)-  | SearchTileA ActorId Point (Kind.Id TileKind) (Kind.Id TileKind)-  | SpotTileA LevelId [(Point, Kind.Id TileKind)]-  | LoseTileA LevelId [(Point, Kind.Id TileKind)]-  | AlterSmellA LevelId Point (Maybe Time) (Maybe Time)-  | SpotSmellA LevelId [(Point, Time)]-  | LoseSmellA LevelId [(Point, Time)]+  | AlterTileA !LevelId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)+  | SearchTileA !ActorId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)+  | SpotTileA !LevelId ![(Point, Kind.Id TileKind)]+  | LoseTileA !LevelId ![(Point, Kind.Id TileKind)]+  | AlterSmellA !LevelId !Point !(Maybe Time) !(Maybe Time)+  | SpotSmellA !LevelId ![(Point, Time)]+  | LoseSmellA !LevelId ![(Point, Time)]   -- Assorted.-  | AgeLevelA LevelId Time-  | AgeGameA Time-  | DiscoverA LevelId Point ItemId (Kind.Id ItemKind)-  | CoverA LevelId Point ItemId (Kind.Id ItemKind)-  | PerceptionA LevelId PerActor PerActor-  | RestartA FactionId Discovery FactionPers State Bool Text-  | RestartServerA State-  | ResumeA FactionId FactionPers-  | ResumeServerA State-  | KillExitA FactionId-  | SaveExitA+  | AgeLevelA !LevelId !Time+  | AgeGameA !Time+  | DiscoverA !LevelId !Point !ItemId !(Kind.Id ItemKind)+  | CoverA !LevelId !Point !ItemId !(Kind.Id ItemKind)+  | PerceptionA !LevelId !PerActor !PerActor+  | RestartA !FactionId !Discovery !FactionPers !State !DebugModeCli !Text+  | RestartServerA !State+  | ResumeA !FactionId !FactionPers+  | ResumeServerA !State+  | KillExitA !FactionId   | SaveBkpA-  | MsgAllA Msg+  | MsgAllA !Msg   deriving (Show, Eq, Generic)  instance Binary CmdAtomic  data SfxAtomic =-    StrikeD ActorId ActorId Item HitAtomic-  | RecoilD ActorId ActorId Item HitAtomic-  | ProjectD ActorId ItemId-  | CatchD ActorId ItemId-  | ActivateD ActorId ItemId-  | CheckD ActorId ItemId-  | TriggerD ActorId Point F.Feature Bool-  | ShunD ActorId Point F.Feature Bool-  | EffectD ActorId (Effect.Effect Int)-  | MsgFidD FactionId Msg-  | MsgAllD Msg-  | DisplayPushD FactionId-  | DisplayDelayD FactionId+    StrikeD !ActorId !ActorId !Item !HitAtomic+  | RecoilD !ActorId !ActorId !Item !HitAtomic+  | ProjectD !ActorId !ItemId+  | CatchD !ActorId !ItemId+  | ActivateD !ActorId !ItemId+  | CheckD !ActorId !ItemId+  | TriggerD !ActorId !Point !F.Feature+  | ShunD !ActorId !Point !F.Feature+  | EffectD !ActorId !(Effect.Effect Int)+  | MsgFidD !FactionId !Msg+  | MsgAllD !Msg+  | DisplayPushD !FactionId+  | DisplayDelayD !FactionId+  | RecordHistoryD !FactionId   deriving (Show, Eq, Generic)  instance Binary SfxAtomic@@ -160,7 +161,6 @@   ResumeA{} -> Nothing   ResumeServerA{} -> Nothing   KillExitA{} -> Nothing-  SaveExitA -> Nothing   SaveBkpA -> Nothing   MsgAllA{} -> Nothing  -- only generated by @cmdAtomicFilterCli@ @@ -172,13 +172,14 @@   CatchD aid iid -> ProjectD aid iid   ActivateD aid iid -> CheckD aid iid   CheckD aid iid -> ActivateD aid iid-  TriggerD aid p feat b -> ShunD aid p feat b-  ShunD aid p feat b -> TriggerD aid p feat b+  TriggerD aid p feat -> ShunD aid p feat+  ShunD aid p feat -> TriggerD aid p feat   EffectD{} -> cmd  -- not ideal?   MsgFidD{} -> cmd   MsgAllD{} -> cmd   DisplayPushD{} -> cmd   DisplayDelayD{} -> cmd+  RecordHistoryD{} -> cmd  undoAtomic :: Atomic -> Maybe Atomic undoAtomic (CmdAtomic cmd) = fmap CmdAtomic $ undoCmdAtomic cmd
Game/LambdaHack/Common/AtomicPos.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Semantics of atomic commands shared by client and server. -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.@@ -9,7 +8,6 @@   ) where  import qualified Data.EnumSet as ES-import Data.Text (Text)  import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor@@ -28,15 +26,15 @@ -- | The type representing visibility of actions to factions, -- based on the position of the action, etc. data PosAtomic =-    PosSight LevelId [Point]  -- ^ whomever sees all the positions, notices-  | PosFidAndSight FactionId LevelId [Point]-                              -- ^ observers and the faction notice-  | PosSmell LevelId [Point]  -- ^ whomever smells all the positions, notices-  | PosFid FactionId          -- ^ only the faction notices-  | PosFidAndSer FactionId    -- ^ faction and server notices-  | PosSer                    -- ^ only the server notices-  | PosAll                    -- ^ everybody notices-  | PosNone                   -- ^ never broadcasted, but sent manually+    PosSight !LevelId ![Point]  -- ^ whomever sees all the positions, notices+  | PosFidAndSight !FactionId !LevelId ![Point]+                                -- ^ observers and the faction notice+  | PosSmell !LevelId ![Point]  -- ^ whomever smells all the positions, notices+  | PosFid !FactionId           -- ^ only the faction notices+  | PosFidAndSer !FactionId     -- ^ faction and server notices+  | PosSer                      -- ^ only the server notices+  | PosAll                      -- ^ everybody notices+  | PosNone                     -- ^ never broadcasted, but sent manually   deriving (Show, Eq)  -- | Produces the positions where the action takes place. If a faction@@ -116,7 +114,6 @@   ResumeA fid _ -> return $ PosFid fid   ResumeServerA _ -> return PosSer   KillExitA fid -> return $ PosFid fid-  SaveExitA -> return PosAll   SaveBkpA -> return PosAll   MsgAllA{} -> return PosAll @@ -134,10 +131,10 @@   CatchD aid _ -> singleAid aid   ActivateD aid _ -> singleAid aid   CheckD aid _ -> singleAid aid-  TriggerD aid p _ _ -> do+  TriggerD aid p _ -> do     (lid, pa) <- posOfAid aid     return $ PosSight lid [pa, p]-  ShunD aid p _ _ -> do+  ShunD aid p _ -> do     (lid, pa) <- posOfAid aid     return $ PosSight lid [pa, p]   EffectD aid _ -> singleAid aid@@ -145,6 +142,7 @@   MsgAllD _ -> return PosAll   DisplayPushD fid -> return $ PosFid fid   DisplayDelayD fid -> return $ PosFid fid+  RecordHistoryD fid -> return $ PosFid fid  singleAid :: MonadActionRO m => ActorId -> m PosAtomic singleAid aid = do@@ -237,11 +235,11 @@     PosFidAndSer fid2 -> fid == fid2     PosSer -> False     PosAll -> True-    PosNone -> assert `failure` fid+    PosNone -> assert `failure` "no position possible" `with` fid  seenAtomicSer :: PosAtomic -> Bool seenAtomicSer posAtomic =   case posAtomic of     PosFid _ -> False-    PosNone -> assert `failure` ("PosNone considered for the server" :: Text)+    PosNone -> assert `failure` "wrong position for server" `with` posAtomic     _ -> True
Game/LambdaHack/Common/AtomicSem.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Semantics of atomic commands shared by client and server. -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.@@ -11,7 +10,6 @@ import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.List-import Data.Maybe  import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor@@ -28,7 +26,6 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.TileKind as TileKind import Game.LambdaHack.Utils.Assert @@ -74,7 +71,6 @@   ResumeA{} -> return ()   ResumeServerA s -> resumeServerA s   KillExitA{} -> return ()-  SaveExitA -> return ()   SaveBkpA -> return ()   MsgAllA{} -> return () @@ -84,11 +80,12 @@ createActorA aid body ais = do   -- Add actor to @sactorD@.   let f Nothing = Just body-      f (Just b) = assert `failure` (aid, body, b)+      f (Just b) = assert `failure` "actor already added" `with` (aid, body, b)   modifyState $ updateActorD $ EM.alter f aid   -- Add actor to @sprio@.   let g Nothing = Just [aid]-      g (Just l) = assert (aid `notElem` l `blame` (aid, body, l))+      g (Just l) = assert (aid `notElem` l `blame` "actor already added"+                                           `with` (aid, body, l))                    $ Just $ aid : l   updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)   -- Actor's items may or may not be already present in @sitemD@,@@ -96,7 +93,8 @@   -- We re-add them all to save time determining which really need it.   forM_ ais $ \(iid, item) -> do     let h item1 item2 =-          assert (item1 == item2 `blame` (aid, body, iid, item1, item2)) item1+          assert (item1 == item2 `blame` "inconsistent created actor items"+                                 `with` (aid, body, iid, item1, item2)) item1     modifyState $ updateItemD $ EM.insertWith h iid item  -- | Update a given level data within state.@@ -111,14 +109,17 @@   -- that do not appear anywhere else, for simplicity and speed.   itemD <- getsState sitemD   let match (iid, item) = itemD EM.! iid == item-  assert (allB match ais `blame` (aid, body, ais, itemD)) skip+  assert (allB match ais `blame` "destroyed actor items not found"+                         `with` (aid, body, ais, itemD)) skip   -- Remove actor from @sactorD@.-  let f Nothing = assert `failure` (aid, body)-      f (Just b) = assert (b == body `blame` (aid, body, b)) Nothing+  let f Nothing = assert `failure` "actor already removed" `with` (aid, body)+      f (Just b) = assert (b == body `blame` "inconsisted destroyed actor body"+                                     `with` (aid, body, b)) Nothing   modifyState $ updateActorD $ EM.alter f aid   -- Remove actor from @sprio@.-  let g Nothing = assert `failure` (aid, body)-      g (Just l) = assert (aid `elem` l `blame` (aid, body, l))+  let g Nothing = assert `failure` "actor already removed" `with` (aid, body)+      g (Just l) = assert (aid `elem` l `blame` "actor already removed"+                                        `with` (aid, body, l))                    $ let l2 = delete aid l                      in if null l2 then Nothing else Just l2   updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)@@ -129,7 +130,9 @@ createItemA iid item k c = assert (k > 0) $ do   -- The item may or may not be already present in @sitemD@,   -- regardless if it's actually present in the dungeon.-  let f item1 item2 = assert (item1 == item2 `blame` (iid, item, k, c)) item1+  let f item1 item2 = assert (item1 == item2+                              `blame` "inconsistent created item"+                              `with` (iid, item, k, c)) item1   modifyState $ updateItemD $ EM.insertWith f iid item   case c of     CFloor lid pos -> insertItemFloor lid iid k pos@@ -161,7 +164,8 @@   -- It's incredibly costly and not noticeable for the player.   -- However, assert the item is registered in @sitemD@.   itemD <- getsState sitemD-  assert (iid `EM.lookup` itemD == Just item `blame` (iid, item, itemD)) skip+  assert (iid `EM.lookup` itemD == Just item `blame` "item already removed"+                                             `with` (iid, item, itemD)) skip   case c of     CFloor lid pos -> deleteItemFloor lid iid k pos     CActor aid l -> deleteItemActor iid k l aid@@ -172,7 +176,8 @@   let rmFromFloor (Just bag) =         let nbag = rmFromBag k iid bag         in if EM.null nbag then Nothing else Just nbag-      rmFromFloor Nothing = assert `failure` (lid, iid, k, pos)+      rmFromFloor Nothing = assert `failure` "item already removed"+                                   `with` (lid, iid, k, pos)   in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos  deleteItemActor :: MonadAction m@@ -182,21 +187,25 @@     EM.adjust (\b -> b {bbag = rmFromBag k iid (bbag b)}) aid   -- Do not remove from actor's @binv@, but assert it was there.   b <- getsState $ getActorBody aid-  assert (l `EM.lookup` binv b == Just iid `blame` (iid, l, aid)) skip+  assert (l `EM.lookup` binv b == Just iid `blame` "item already removed"+                                           `with` (iid, l, aid)) skip   -- Actor's @bletter@ for UI not reset, but checked.-  assert (bletter b >= l`blame` (iid, k, l, aid, bletter b)) skip+  assert (bletter b >= l`blame` "inconsistent actor inventory letter"+                        `with` (iid, k, l, aid, bletter b)) skip  moveActorA :: MonadAction m => ActorId -> Point -> Point -> m () moveActorA aid fromP toP = assert (fromP /= toP) $ do   b <- getsState $ getActorBody aid-  assert (fromP == bpos b `blame` (aid, fromP, toP, bpos b, b)) skip+  assert (fromP == bpos b `blame` "unexpected moved actor position"+                          `with` (aid, fromP, toP, bpos b, b)) skip   modifyState $ updateActorBody aid               $ \body -> body {bpos = toP, boldpos = fromP}  waitActorA :: MonadAction m => ActorId -> Time -> Time -> m () waitActorA aid fromWait toWait = assert (fromWait /= toWait) $ do   b <- getsState $ getActorBody aid-  assert (fromWait == bwait b `blame` (aid, fromWait, toWait, bwait b, b)) skip+  assert (fromWait == bwait b `blame` "unexpected waited actor time"+                              `with` (aid, fromWait, toWait, bwait b, b)) skip   modifyState $ updateActorBody aid $ \body -> body {bwait = toWait}  displaceActorA :: MonadAction m => ActorId -> ActorId -> m ()@@ -210,7 +219,8 @@ moveItemA iid k c1 c2 = assert (k > 0 && c1 /= c2) $ do   (lid1, _) <- posOfContainer c1   (lid2, _) <- posOfContainer c2-  assert (lid1 == lid2 `blame` (iid, k, c1, c2, lid1, lid2)) skip+  assert (lid1 == lid2 `blame` "moved item containers not on the same level"+                       `with` (iid, k, c1, c2, lid1, lid2)) skip   case c1 of     CFloor lid pos -> deleteItemFloor lid iid k pos     CActor aid l -> deleteItemActor iid k l aid@@ -233,7 +243,12 @@   body <- getsState $ getActorBody aid   ais <- getsState $ getActorItem aid   destroyActorA aid body ais-  createActorA aid body {btime = timeAdd (btime body) t} ais+  let newBody = body { btime = timeAdd (btime body) t+                     , bwait = if bwait body <= btime body+                               then timeZero    -- reset old waiting time+                               else bwait body  -- keep new waiting time+                     }+  createActorA aid newBody ais  healActorA :: MonadAction m => ActorId -> Int -> m () healActorA aid n = assert (n /= 0) $@@ -241,28 +256,26 @@  hasteActorA :: MonadAction m => ActorId -> Speed -> m () hasteActorA aid delta = assert (delta /= speedZero) $ do-  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops   modifyState $ updateActorBody aid $ \ b ->-    let innateSpeed = aspeed $ okind $ bkind b-        curSpeed = fromMaybe innateSpeed (bspeed b)-        newSpeed = speedAdd curSpeed delta-    in assert (newSpeed >= speedZero `blame` (aid, curSpeed, delta)) $-       if newSpeed == innateSpeed-       then b {bspeed = Nothing}-       else b {bspeed = Just newSpeed}+    let newSpeed = speedAdd (bspeed b) delta+    in assert (newSpeed >= speedZero `blame` "actor slowed below zero"+                                     `with` (aid, delta, bspeed b, newSpeed)) $+       b {bspeed = newSpeed}  pathActorA :: MonadAction m            => ActorId -> Maybe [Vector] -> Maybe [Vector] -> m () pathActorA aid fromPath toPath = assert (fromPath /= toPath) $ do   body <- getsState $ getActorBody aid-  assert (fromPath == bpath body `blame` (aid, fromPath, toPath, body)) skip+  assert (fromPath == bpath body `blame` "unexpected actor path"+                                 `with` (aid, fromPath, toPath, body)) skip   modifyState $ updateActorBody aid $ \b -> b {bpath = toPath}  colorActorA :: MonadAction m-            => ActorId -> Maybe Color.Color -> Maybe Color.Color -> m ()+            => ActorId -> Color.Color -> Color.Color -> m () colorActorA aid fromCol toCol = assert (fromCol /= toCol) $ do   body <- getsState $ getActorBody aid-  assert (fromCol == bcolor body `blame` (aid, fromCol, toCol, body)) skip+  assert (fromCol == bcolor body `blame` "unexpected actor color"+                                 `with` (aid, fromCol, toCol, body)) skip   modifyState $ updateActorBody aid $ \b -> b {bcolor = toCol}  quitFactionA :: MonadAction m@@ -271,7 +284,8 @@ quitFactionA fid mbody fromSt toSt = assert (fromSt /= toSt) $ do   assert (maybe True ((fid ==) . bfid) mbody) skip   fact <- getsState $ (EM.! fid) . sfactionD-  assert (fromSt == gquit fact `blame` (fid, fromSt, toSt, fact)) skip+  assert (fromSt == gquit fact `blame` "unexpected actor quit status"+                               `with` (fid, fromSt, toSt, fact)) skip   let adj fa = fa {gquit = toSt}   modifyState $ updateFaction $ EM.adjust adj fid @@ -280,7 +294,8 @@              => FactionId -> Maybe ActorId -> Maybe ActorId -> m () leadFactionA fid source target = assert (source /= target) $ do   fact <- getsState $ (EM.! fid) . sfactionD-  assert (source == gleader fact `blame` (fid, source, target, fact)) skip+  assert (source == gleader fact `blame` "unexpected actor leader"+                                 `with` (fid, source, target, fact)) skip   let adj fa = fa {gleader = target}   modifyState $ updateFaction $ EM.adjust adj fid @@ -292,7 +307,8 @@     fact2 <- getsState $ (EM.! fid2) . sfactionD     assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1)             && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2)-            `blame` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) skip+            `blame` "unexpected actor diplomacy status"+            `with` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) skip     let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}     modifyState $ updateFaction $ EM.adjust (adj fid2) fid1     modifyState $ updateFaction $ EM.adjust (adj fid1) fid2@@ -304,7 +320,8 @@            -> m () alterTileA lid p fromTile toTile = assert (fromTile /= toTile) $ do   Kind.COps{cotile} <- getsState scops-  freshClientTile <- getsLevel lid $ hideTile cotile p+  lvl <- getLevel lid+  let freshClientTile = hideTile cotile lvl p   -- The second alternative can happen if, e.g., a client remembers,   -- but does not see the tile (so does not notice the SearchTileA action),   -- and it suddenly changes into another tile,@@ -312,12 +329,13 @@   -- See 'AtomicSemCli' for how this is reported to the client.   let adj ts = assert (ts Kind.! p == fromTile                        || ts Kind.! p == freshClientTile-                       `blame` (lid, p, fromTile, toTile, ts Kind.! p))+                       `blame` "unexpected altered tile kind"+                       `with` (lid, p, fromTile, toTile, ts Kind.! p))                $ ts Kind.// [(p, toTile)]   updateLevel lid $ updateTile adj   case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of-    (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl + 1}-    (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}+    (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}+    (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}     _ -> return ()  -- Notice a previously invisible tiles. This is similar to @SpotActorA@,@@ -329,18 +347,18 @@ spotTileA :: MonadAction m => LevelId -> [(Point, Kind.Id TileKind)] -> m () spotTileA lid ts = assert (not $ null ts) $ do   Kind.COps{cotile} <- getsState scops-  tileM <- getsLevel lid ltile+  Level{ltile} <- getLevel lid   let adj tileMap = tileMap Kind.// ts   updateLevel lid $ updateTile adj   let f (p, t2) = do-        let t1 = tileM Kind.! p+        let t1 = ltile Kind.! p         case (Tile.isExplorable cotile t1, Tile.isExplorable cotile t2) of           (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1}           (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1}           _ -> return ()   mapM_ f ts --- Stop noticing a previously invisible tiles. Unlike @spotTileA@, it verifies+-- Stop noticing a previously visible tiles. Unlike @spotTileA@, it verifies -- the state of the tiles before changing them. loseTileA :: MonadAction m => LevelId -> [(Point, Kind.Id TileKind)] -> m () loseTileA lid ts = assert (not $ null ts) $ do@@ -361,7 +379,8 @@             => LevelId -> Point -> Maybe Time -> Maybe Time -> m () alterSmellA lid p _fromSm toSm = do   -- TODO: this rarely crashes when a dominated smelling monster exists:-  -- let alt sm = assert (sm == fromSm `blame` (lid, p, fromSm, toSm, sm)) toSm+  -- let alt sm = assert (sm == fromSm `blame` "unexpected tile smell"+  --                                   `with` (lid, p, fromSm, toSm, sm)) toSm   let alt _ =  toSm   updateLevel lid $ updateSmell $ EM.alter alt p @@ -371,16 +390,19 @@       alt sm (Just _) = Just sm -- TODO: a hack to sidestep server not disabling the nose of fresh actors, -- see smellFromActors---      alt sm (Just oldSm) = assert `failure` (lid, sms, sm, oldSm)+--      alt sm (Just oldSm) = assert `failure` "smell already added"+--                                   `with` (lid, sms, sm, oldSm)       f (p, sm) = EM.alter (alt sm) p       upd m = foldr f m sms   updateLevel lid $ updateSmell upd  loseSmellA :: MonadAction m => LevelId -> [(Point, Time)] -> m () loseSmellA lid sms = assert (not $ null sms) $ do-  let alt sm Nothing = assert `failure` (lid, sms, sm)+  let alt sm Nothing = assert `failure` "smell already removed"+                              `with` (lid, sms, sm)       alt sm (Just oldSm) =-        assert (sm == oldSm `blame` (lid, sms, sm, oldSm)) Nothing+        assert (sm == oldSm `blame` "unexpected lost smell"+                            `with` (lid, sms, sm, oldSm)) Nothing       f (p, sm) = EM.alter (alt sm) p       upd m = foldr f m sms   updateLevel lid $ updateSmell upd
Game/LambdaHack/Common/ClientCmd.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Abstract syntax of client commands. -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.@@ -12,6 +10,7 @@ import Control.Concurrent.STM.TQueue import qualified Data.EnumMap.Strict as EM import Data.Text (Text)+import qualified Data.Text as T  import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor@@ -19,61 +18,93 @@ import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.AtomicPos import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time import Game.LambdaHack.Frontend  -- | Abstract syntax of client commands that don't use the UI. data CmdClientAI =-    CmdAtomicAI CmdAtomic-  | CmdQueryAI ActorId+    CmdAtomicAI !CmdAtomic+  | CmdQueryAI !ActorId+  | CmdPingAI   deriving Show  -- | Abstract syntax of client commands that use the UI. data CmdClientUI =-    CmdAtomicUI CmdAtomic-  | SfxAtomicUI SfxAtomic-  | CmdQueryUI ActorId+    CmdAtomicUI !CmdAtomic+  | SfxAtomicUI !SfxAtomic+  | CmdQueryUI !ActorId+  | CmdPingUI   deriving Show  debugCmdClientAI :: MonadActionRO m => CmdClientAI -> m Text debugCmdClientAI cmd = case cmd of-  CmdAtomicAI cmdA -> do-    ps <- posCmdAtomic cmdA-    return $ showT (showT cmd, ps)-  CmdQueryAI aid -> debugAid aid $ showT cmd+  CmdAtomicAI cmdA@PerceptionA{} -> debugPlain cmd cmdA+  CmdAtomicAI cmdA@ResumeA{} -> debugPlain cmd cmdA+  CmdAtomicAI cmdA@SpotTileA{} -> debugPlain cmd cmdA+  CmdAtomicAI cmdA -> debugPretty cmd cmdA+  CmdQueryAI aid -> debugAid aid "CmdQueryAI" cmd+  CmdPingAI -> return $ showT cmd  debugCmdClientUI :: MonadActionRO m => CmdClientUI -> m Text debugCmdClientUI cmd = case cmd of-  CmdAtomicUI cmdA -> do-    ps <- posCmdAtomic cmdA-    return $ showT (showT cmd, ps)+  CmdAtomicUI cmdA@PerceptionA{} -> debugPlain cmd cmdA+  CmdAtomicUI cmdA@ResumeA{} -> debugPlain cmd cmdA+  CmdAtomicUI cmdA@SpotTileA{} -> debugPlain cmd cmdA+  CmdAtomicUI cmdA -> debugPretty cmd cmdA   SfxAtomicUI sfx -> do     ps <- posSfxAtomic sfx-    return $ showT (showT cmd, ps)-  CmdQueryUI aid -> debugAid aid $ showT cmd+    return $ showT (cmd, ps)+  CmdQueryUI aid -> debugAid aid "CmdQueryUI" cmd+  CmdPingUI -> return $ showT cmd -debugAid :: MonadActionRO m => ActorId -> Text -> m Text-debugAid aid s = do-  b <- getsState $ getActorBody aid-  time <- getsState $ getLocalTime (blid b)-  return $-    showT (s, "lid", blid b, "time", time, "aid", aid, "faction", bfid b)+debugPretty :: (MonadActionRO m, Show a) => a -> CmdAtomic -> m Text+debugPretty cmd cmdA = do+  ps <- posCmdAtomic cmdA+  return $ showT (cmd, ps) --- | Connection channels between the server and a single client.-data ChanServer c = ChanServer-  { fromServer :: TQueue c-  , toServer   :: TQueue CmdSer+debugPlain :: (MonadActionRO m, Show a) => a -> CmdAtomic -> m Text+debugPlain cmd cmdA = do+  ps <- posCmdAtomic cmdA+  return $ T.pack $ show (cmd, ps)  -- too large for pretty show++data DebugAid a = DebugAid+  { label   :: !Text+  , cmd     :: !a+  , lid     :: !LevelId+  , time    :: !Time+  , aid     :: !ActorId+  , faction :: !FactionId   }+  deriving Show -instance Show (ChanServer c) where-  show _ = "client-server connection channels"+debugAid :: (MonadActionRO m, Show a) => ActorId -> Text -> a -> m Text+debugAid aid label cmd =+  if aid == toEnum (-1) then+    return ""+  else do+    b <- getsState $ getActorBody aid+    time <- getsState $ getLocalTime (blid b)+    return $ showT DebugAid { label+                            , cmd+                            , lid = blid b+                            , time+                            , aid+                            , faction = bfid b } --- | Connection to the human-controlled client of a faction and/or+-- | Connection channels between the server and a single client.+data ChanServer c d = ChanServer+  { fromServer :: !(TQueue c)+  , toServer   :: !(TQueue d)+  }++-- | Connections to the human-controlled client of a faction and -- to the AI client for the same faction.-type ConnServerFaction = ( (ChanFrontend, ChanServer CmdClientUI)-                         , ChanServer CmdClientAI )+type ConnServerFaction = ( Maybe (ChanFrontend, ChanServer CmdClientUI CmdSer)+                         , ChanServer CmdClientAI CmdSerTakeTime )  -- | Connection information for all factions, indexed by faction identifier. type ConnServerDict = EM.EnumMap FactionId ConnServerFaction
Game/LambdaHack/Common/Effect.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveFunctor, DeriveGeneric, OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor, DeriveGeneric #-} -- | Effects of content on other content. No operation in this module -- involves the 'State' or 'Action' type. module Game.LambdaHack.Common.Effect-  ( Effect(..), effectTrav, effectToSuffix, effectToBenefit+  ( Effect(..), effectTrav, effectToSuffix   ) where  import qualified Control.Monad.State as St@@ -20,18 +20,17 @@ -- either as a random formula dependent on level, or as a final rolled value. data Effect a =     NoEffect-  | Heal Int-  | Hurt !RollDice a-  | Mindprobe Int       -- the @Int@ is a hack to send the result to clients+  | Heal !Int+  | Hurt !RollDice !a+  | Mindprobe !Int    -- the @Int@ is a hack to send the result to clients   | Dominate-  | CallFriend Int-  | Summon Int-  | CreateItem Int+  | CallFriend !Int+  | Summon !Int+  | CreateItem !Int   | ApplyPerfume-  | Regeneration a-  | Searching a-  | Ascend Int-  | Descend Int+  | Regeneration !a+  | Searching !a+  | Ascend !Int   | Escape   deriving (Show, Read, Eq, Ord, Generic, Functor) @@ -60,11 +59,10 @@   b <- f a   return $ Searching b effectTrav (Ascend p) _ = return $ Ascend p-effectTrav (Descend p) _ = return $ Descend p effectTrav Escape _ = return Escape  -- | Suffix to append to a basic content name if the content causes the effect.-effectToSuff :: Effect a -> (a -> Text) -> Text+effectToSuff :: Show a => Effect a -> (a -> Text) -> Text effectToSuff effect f =   case St.evalState (effectTrav effect $ return . f) () of     NoEffect -> ""@@ -80,8 +78,9 @@     ApplyPerfume -> "of rose water"     Regeneration t -> "of regeneration" <> t     Searching t -> "of searching" <> t-    Ascend p -> "of ascending" <> affixPower p-    Descend p -> "of descending" <> affixPower p+    Ascend p | p > 0 -> "of ascending" <> affixPower p+    Ascend p | p < 0 -> "of descending" <> affixPower (- p)+    Ascend{} -> assert `failure` effect     Escape -> "of escaping"  effectToSuffix :: Effect Int -> Text@@ -90,7 +89,7 @@ affixPower :: Int -> Text affixPower p = case compare p 1 of   EQ -> ""-  LT -> assert `failure` p+  LT -> assert `failure` "power less than 1" `with` p   GT -> " (+" <> showT p <> ")"  affixBonus :: Int -> Text@@ -98,23 +97,3 @@   EQ -> ""   LT -> " (" <> showT p <> ")"   GT -> " (+" <> showT p <> ")"---- | How much AI benefits from applying the effect. Multipllied by item p.--- Negative means harm to the enemy when thrown at him. Effects with zero--- benefit won't ever be used, neither actively nor passively.-effectToBenefit :: Effect Int -> Int-effectToBenefit NoEffect = 0-effectToBenefit (Heal p) = p * 10       -- TODO: depends on (maxhp - hp)-effectToBenefit (Hurt _ p) = -(p * 10)  -- TODO: dice ignored for now-effectToBenefit Mindprobe{} = 0         -- AI can't benefit yet-effectToBenefit Dominate = 1            -- hard to use; TODO: limit by IQ-effectToBenefit (CallFriend p) = p * 100-effectToBenefit Summon{} = 5            -- may or may not spawn a friendly-effectToBenefit (CreateItem p) = p * 20-effectToBenefit ApplyPerfume = 0-effectToBenefit Regeneration{} = 0      -- bigger benefit from carrying around-effectToBenefit Searching{} = 0         -- AI doesn't search yet-effectToBenefit Ascend{} = 5            -- AI can't choose levels smartly yet-effectToBenefit Descend{} = 20          -- but it prefers to hide deep down-effectToBenefit Escape = 100            -- hero AI wants to win ASAP, monster-                                        -- AI sits on the exit to block it
Game/LambdaHack/Common/Faction.hs view
@@ -1,15 +1,12 @@-{-# LANGUAGE OverloadedStrings #-} -- | Factions taking part in the game: e.g., two human players controlling -- the hero faction battling the monster and the animal factions. module Game.LambdaHack.Common.Faction   ( FactionId, FactionDict, Faction(..), Diplomacy(..), Outcome(..), Status(..)-  , isHumanFact, usesAIFact, isSpawnFact, isSummonFact-  , isAtWar, isAllied+  , isSpawnFact, isSummonFact, isAtWar, isAllied   ) where  import Data.Binary import qualified Data.EnumMap.Strict as EM-import Data.Maybe import Data.Text (Text)  import Game.LambdaHack.Common.Actor@@ -17,27 +14,19 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.StrategyKind+import Game.LambdaHack.Content.ModeKind  -- | All factions in the game, indexed by faction identifier. type FactionDict = EM.EnumMap FactionId Faction  data Faction = Faction-  { gkind     :: !(Kind.Id FactionKind)   -- ^ the kind of the faction-  , gname     :: !Text                    -- ^ individual name-  , gconfig   :: !Text                    -- ^ raw name specified in config-  , gAiLeader :: !(Maybe (Kind.Id StrategyKind))-                                          -- ^ AI for the leaders;-                                          -- Nothing means human-controlled-  , gAiMember :: !(Maybe (Kind.Id StrategyKind))-                                          -- ^ AI to use for other actors;-                                          -- Nothing means human-controlled-  , gdipl     :: !Dipl                    -- ^ diplomatic mode-  , gquit     :: !(Maybe Status)          -- ^ cause of game end/exit-  , gleader   :: !(Maybe ActorId)-  , gcolor    :: !Color.Color             -- ^ color of actors or their frames-  , ginitial  :: !Int                     -- ^ number of initial actors-  , gentry    :: !LevelId                 -- ^ level where initial actors start+  { gkind   :: !(Kind.Id FactionKind)  -- ^ the kind of the faction+  , gname   :: !Text                   -- ^ individual name+  , gcolor  :: !Color.Color            -- ^ color of actors or their frames+  , gplayer :: !Player                 -- ^ the player spec for this faction+  , gdipl   :: !Dipl                   -- ^ diplomatic mode+  , gquit   :: !(Maybe Status)         -- ^ cause of game end/exit+  , gleader :: !(Maybe ActorId)        -- ^ the leader of the faction, if any   }   deriving (Show, Eq) @@ -63,27 +52,19 @@  -- | Current game status. data Status = Status-  { stOutcome :: Outcome  -- ^ current game outcome-  , stDepth   :: Int      -- ^ depth of the final encounter-  , stInfo    :: Text     -- ^ extra information+  { stOutcome :: !Outcome  -- ^ current game outcome+  , stDepth   :: !Int      -- ^ depth of the final encounter+  , stInfo    :: !Text     -- ^ extra information   }   deriving (Show, Eq, Ord) --- | Tell whether the faction is controlled (at least partially) by a human.-isHumanFact :: Faction -> Bool-isHumanFact fact = isNothing (gAiLeader fact) || isNothing (gAiMember fact)---- | Tell whether the faction uses AI to control any of its actors.-usesAIFact :: Faction -> Bool-usesAIFact fact = isJust (gAiLeader fact) || isJust (gAiMember fact)- -- | Tell whether the faction can spawn actors. isSpawnFact :: Kind.COps -> Faction -> Bool isSpawnFact Kind.COps{cofact=Kind.Ops{okind}} fact =   let kind = okind (gkind fact)   in maybe False (> 0) $ lookup "spawn" $ ffreq kind --- | Tell whether actors of the faction can be summoned by items, etc..+-- | Tell whether actors of the faction can be summoned by items, etc. isSummonFact :: Kind.COps -> Faction -> Bool isSummonFact Kind.COps{cofact=Kind.Ops{okind}} fact =   let kind = okind (gkind fact)@@ -101,27 +82,19 @@   put Faction{..} = do     put gkind     put gname-    put gconfig-    put gAiLeader-    put gAiMember+    put gcolor+    put gplayer     put gdipl     put gquit     put gleader-    put gcolor-    put ginitial-    put gentry   get = do     gkind <- get     gname <- get-    gconfig <- get-    gAiLeader <- get-    gAiMember <- get+    gcolor <- get+    gplayer <- get     gdipl <- get     gquit <- get     gleader <- get-    gcolor <- get-    ginitial <- get-    gentry <- get     return Faction{..}  instance Binary Diplomacy where
Game/LambdaHack/Common/Feature.hs view
@@ -13,14 +13,12 @@ -- | All possible terrain tile features, some of them parameterized -- or dependent on outside coefficients, e.g., on the tile secrecy value. data Feature =-    Ascendable           -- ^ triggered by ascending-  | Descendable          -- ^ triggered by descending-  | Escapable            -- ^ triggered by escaping-  | Openable             -- ^ triggered by opening-  | Closable             -- ^ triggered by closing--  | Cause !(Effect Int)  -- ^ causes the effect when triggered-  | ChangeTo !Text       -- ^ transitions to a tile of the group when triggered+    Cause !(Effect Int)  -- ^ causes the effect when triggered+  | OpenTo !Text         -- ^ goes from an open to a closed tile when altered+  | CloseTo !Text        -- ^ goes from a closed to an open tile when altered+  | ChangeTo !Text       -- ^ alters tile, but does not change walkability+  | HideAs !Text         -- ^ when hidden, looks as a tile of the group+  | RevealAs !Text       -- ^ if secret, can be revealed to belong to the group    | Walkable             -- ^ actors can walk through   | Clear                -- ^ actors can see through@@ -33,7 +31,6 @@   | CanActor             -- ^ actors and stairs can be generated there   | Exit                 -- ^ is a (not hidden) door, stair, etc.   | Path                 -- ^ used for visible paths throughout the level-  | HiddenAs !Text       -- ^ when hidden, looks as a tile of the group   deriving (Show, Read, Eq, Ord, Generic)  instance Binary Feature
Game/LambdaHack/Common/Flavour.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-} -- | The appearance of in-game items, as communicated to the player. module Game.LambdaHack.Common.Flavour   ( -- * The @Flavour@ type@@ -22,8 +22,8 @@ -- TODO: add more variety, as the number of items increases -- | The type of item flavours. data Flavour = Flavour-  { fancyName :: Bool   -- ^ should the colour description be fancy or plain-  , baseColor :: Color  -- ^ the colour of the flavour+  { fancyName :: !Bool   -- ^ should the colour description be fancy or plain+  , baseColor :: !Color  -- ^ the colour of the flavour   }   deriving (Show, Eq, Ord, Generic)
Game/LambdaHack/Common/HighScore.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore   ( ScoreTable, empty, register, slideshow@@ -32,7 +32,7 @@ showScore (pos, score) =   let Status{stOutcome, stDepth} = status score       died = case stOutcome of-        Killed -> "perished on level " ++ show stDepth ++ ","+        Killed -> "perished on level " ++ show (abs stDepth) ++ ","         Defeated -> "was defeated"         Camping -> "is camping somewhere,"         Conquer -> "eliminated all opposition"
Game/LambdaHack/Common/Item.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Weapons, treasure and all the other items in the game. -- No operation in this module -- involves the 'State' or 'Action' type.@@ -25,7 +25,6 @@ import Data.List import qualified Data.Set as S import Data.Text (Text)-import qualified Data.Text as T import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU @@ -89,7 +88,7 @@   let f ik _ (ikMap, ikRev, ix : rest) =         (EM.insert ix ik ikMap, EM.insert ik ix ikRev, rest)       f ik  _ (ikMap, _, []) =-        assert `failure` (ik, ikMap, "too short ixs" :: Text)+        assert `failure` "too short ixs" `with` (ik, ikMap)       (discoS, discoRev, _) =         ofoldrWithKey f (EM.empty, EM.empty, shuffled)   return (discoS, discoRev)@@ -111,14 +110,14 @@ newItem :: Kind.Ops ItemKind -> FlavourMap -> DiscoRev -> Int -> Int         -> Rnd (Item, Int, ItemKind) newItem cops@Kind.Ops{opick, okind} flavour discoRev lvl depth = do-  ikChosen <- opick (T.pack "dng") (const True)+  ikChosen <- opick "dng" (const True)   let kind = okind ikChosen-  jcount <- rollDeep lvl depth (icount kind)+  jcount <- castDeep lvl depth (icount kind)   if jcount == 0     then -- Rare item; beware of inifite loops.          newItem cops flavour discoRev lvl depth     else do-      effect <- effectTrav (ieffect kind) (rollDeep lvl depth)+      effect <- effectTrav (ieffect kind) (castDeep lvl depth)       return ( buildItem flavour discoRev ikChosen kind effect              , jcount              , kind )
Game/LambdaHack/Common/Key.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE OverloadedStrings #-} -- | Frontend-independent keyboard input operations. module Game.LambdaHack.Common.Key   ( Key(..), handleDir, dirAllMoveKey-  , moveBinding, keyTranslate, Modifier(..), KM(..), showKM+  , moveBinding, keyTranslate, Modifier(..), KM(..), showKM, escKey   ) where  import Data.Binary@@ -35,9 +34,9 @@   | End   | Begin   | Home-  | KP !Char        -- ^ a keypad key for a character (digits and operators)-  | Char !Char      -- ^ a single printable character-  | Unknown !String -- ^ an unknown key, registered to warn the user+  | KP !Char      -- ^ a keypad key for a character (digits and operators)+  | Char !Char    -- ^ a single printable character+  | Unknown !Text -- ^ an unknown key, registered to warn the user   deriving (Ord, Eq)  instance Binary Key where@@ -129,13 +128,16 @@ showKey Begin    = "BEGIN" showKey Home     = "HOME" showKey (KP c)   = "KEYPAD(" <> T.singleton c <> ")"-showKey (Unknown s) = T.pack s+showKey (Unknown s) = s  -- | Show a key with a modifier, if any. showKM :: KM -> Text showKM KM{modifier=Control, key} = "CTRL-" <> showKey key showKM KM{modifier=NoModifier, key} = showKey key +escKey :: KM+escKey = KM {modifier = NoModifier, key = Esc}+ dirViChar :: [Char] dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h'] @@ -229,4 +231,4 @@ keyTranslate "KP_Enter"      = Return keyTranslate ['K','P','_',c] = KP c keyTranslate [c]             = Char c-keyTranslate s               = Unknown s+keyTranslate s               = Unknown $ T.pack s
Game/LambdaHack/Common/Kind.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings, RankNTypes,-             TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind   ( -- * General content types@@ -26,9 +25,9 @@ import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.StrategyKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.Frequency@@ -55,57 +54,53 @@  -- | Content operations for the content of type @a@. data Ops a = Ops-  { osymbol       :: Id a -> Char  -- ^ the symbol of a content element at id-  , oname         :: Id a -> Text  -- ^ the name of a content element at id-  , okind         :: Id a -> a     -- ^ the content element at given id-  , ouniqGroup    :: Text -> Id a  -- ^ the id of the unique member of-                                   --   a singleton content group+  { okind         :: Id a -> a      -- ^ the content element at given id+  , ouniqGroup    :: Text -> Id a   -- ^ the id of the unique member of+                                    --   a singleton content group   , opick         :: Text -> (a -> Bool) -> Rnd (Id a)-                                   -- ^ pick a random id belonging to a group-                                   --   and satisfying a predicate+                                    -- ^ pick a random id belonging to a group+                                    --   and satisfying a predicate   , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b-                                   -- ^ fold over all content elements of @a@-  , obounds       :: (Id a, Id a)  -- ^ bounds of identifiers of content @a@-  , ospeedup      :: Speedup a     -- ^ auxiliary speedup components+                                    -- ^ fold over all content elements of @a@+  , obounds       :: !(Id a, Id a)  -- ^ bounds of identifiers of content @a@+  , ospeedup      :: !(Maybe (Speedup a))  -- ^ auxiliary speedup components   }  -- | Create content operations for type @a@ from definition of content -- of type @a@. createOps :: forall a. Show a => ContentDef a -> Ops a-createOps ContentDef{getSymbol, getName, getFreq, content, validate} =+createOps ContentDef{getName, getFreq, content, validate} =   assert (Id (fromIntegral $ length content) < sentinelId) $-  let kindAssocs :: [(Word8, a)]-      kindAssocs = L.zip [0..] content-      kindMap :: EM.EnumMap (Id a) a-      kindMap = EM.fromDistinctAscList $ L.zip [Id 0..] content+  let kindMap :: EM.EnumMap (Id a) a+      !kindMap = EM.fromDistinctAscList $ L.zip [Id 0..] content       kindFreq :: M.Map Text (Frequency (Id a, a))       kindFreq =-        let tuples = [ (group, (n, (Id i, k)))-                     | (i, k) <- kindAssocs+        let tuples = [ (group, (n, (i, k)))+                     | (i, k) <- EM.assocs kindMap                      , (group, n) <- getFreq k, n > 0 ]             f m (group, nik) = M.insertWith (++) group [nik] m             lists = L.foldl' f M.empty tuples             nameFreq group = toFreq $ "opick ('" <> group <> "')"         in M.mapWithKey nameFreq lists-      okind i = fromMaybe (assert `failure` (i, kindMap))+      okind i = fromMaybe (assert `failure` "no kind" `with` (i, kindMap))                 $ EM.lookup i kindMap       correct a = not (T.null (getName a)) && L.all ((> 0) . snd) (getFreq a)       offenders = validate content   in assert (allB correct content) $-     assert (L.null offenders `blame` ("content failed validation: " :: Text,-                                       offenders))+     assert (L.null offenders `blame` "content not valid" `with` offenders)+     -- By this point 'content' can be GCd.      Ops-       { osymbol = getSymbol . okind-       , oname = getName . okind-       , okind = okind-       , ouniqGroup = \ group ->-           let freq = fromMaybe (assert `failure` (group, kindFreq))+       { okind+       , ouniqGroup = \group ->+           let freq = fromMaybe (assert `failure` "no unique group"+                                        `with` (group, kindFreq))                       $ M.lookup group kindFreq            in case runFrequency freq of              [(n, (i, _))] | n > 0 -> i-             l -> assert `failure` l-       , opick = \ group p ->-           let freq = fromMaybe (assert `failure` (group, kindFreq))+             l -> assert `failure` "not unique" `with` (l, group, kindFreq)+       , opick = \group p ->+           let freq = fromMaybe (assert `failure` "no group to pick from"+                                        `with` (group, kindFreq))                       $ M.lookup group kindFreq            in frequency $ do              (i, k) <- freq@@ -113,10 +108,11 @@              {- with MonadComprehensions:              frequency [ i | (i, k) <- kindFreq M.! group, p k ]              -}-       , ofoldrWithKey = \ f z -> L.foldr (\ (i, a) -> f (Id i) a) z kindAssocs+       , ofoldrWithKey = \f z -> L.foldr (\(i, a) -> f i a) z+                                 $ EM.assocs kindMap        , obounds = ( fst $ EM.findMin kindMap                    , fst $ EM.findMax kindMap )-       , ospeedup = undefined  -- define elsewhere+       , ospeedup = Nothing  -- define elsewhere        }  -- | Operations for all content types, gathered together.@@ -125,9 +121,9 @@   , cocave  :: !(Ops CaveKind)   , cofact  :: !(Ops FactionKind)   , coitem  :: !(Ops ItemKind)+  , comode  :: !(Ops ModeKind)   , coplace :: !(Ops PlaceKind)   , corule  :: !(Ops RuleKind)-  , costrat :: !(Ops StrategyKind)   , cotile  :: !(Ops TileKind)   }
Game/LambdaHack/Common/Level.hs view
@@ -12,7 +12,7 @@     -- * Level update   , updatePrio, updateSmell, updateFloor, updateTile     -- * Level query-  , at, atI, accessible, accessibleDir, hideTile+  , at, atI, accessible, accessibleDir, isSecretPos, hideTile   , findPos, findPosTry, mapLevelActors_, mapDungeonActors_  ) where @@ -47,16 +47,16 @@   let (minD, maxD) =         case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` dungeon-      ln = max minD $ min maxD $ toEnum $ fromEnum lid - k+          _ -> assert `failure` "null dungeon" `with` dungeon+      ln = max minD $ min maxD $ toEnum $ fromEnum lid + k   in case EM.lookup ln dungeon of     Just _ | ln /= lid -> [ln]     _ -> []  -- | Item container type. data Container =-    CFloor LevelId Point-  | CActor ActorId InvChar+    CFloor !LevelId !Point+  | CActor !ActorId !InvChar   deriving (Show, Eq, Ord, Generic)  instance Binary Container@@ -76,21 +76,22 @@ -- | A view on single, inhabited dungeon level. "Remembered" fields -- carry a subset of the info in the client copies of levels. data Level = Level-  { ldepth   :: !Int             -- ^ depth of the level-  , lprio    :: !ActorPrio       -- ^ remembered actor times on the level-  , lfloor   :: !ItemFloor       -- ^ remembered items lying on the floor-  , ltile    :: !TileMap         -- ^ remembered level map-  , lxsize   :: !X               -- ^ width of the level-  , lysize   :: !Y               -- ^ height of the level-  , lsmell   :: !SmellMap        -- ^ remembered smells on the level-  , ldesc    :: !Text            -- ^ level description-  , lstair   :: !(Point, Point)  -- ^ destination of (up, down) stairs-  , lseen    :: !Int             -- ^ currently remembered clear tiles-  , lclear   :: !Int             -- ^ total number of initially clear tiles-  , ltime    :: !Time            -- ^ date of the last activity on the level-  , litemNum :: !Int             -- ^ number of initial items, 0 for clients-  , lsecret  :: !Int             -- ^ secret level seed, unknown by clients-  , lhidden  :: !Int             -- ^ secret tile density, unknown by clients+  { ldepth   :: !Int        -- ^ depth of the level+  , lprio    :: !ActorPrio  -- ^ remembered actor times on the level+  , lfloor   :: !ItemFloor  -- ^ remembered items lying on the floor+  , ltile    :: !TileMap    -- ^ remembered level map+  , lxsize   :: !X          -- ^ width of the level+  , lysize   :: !Y          -- ^ height of the level+  , lsmell   :: !SmellMap   -- ^ remembered smells on the level+  , ldesc    :: !Text       -- ^ level description+  , lstair   :: !([Point], [Point])+                            -- ^ destinations of (up, down) stairs+  , lseen    :: !Int        -- ^ currently remembered clear tiles+  , lclear   :: !Int        -- ^ total number of initially clear tiles+  , ltime    :: !Time       -- ^ date of the last activity on the level+  , litemNum :: !Int        -- ^ number of initial items, 0 for clients+  , lsecret  :: !Int        -- ^ secret tile seed+  , lhidden  :: !Int        -- ^ secret tile density   }   deriving (Show, Eq) @@ -112,7 +113,7 @@  assertSparseItems :: ItemFloor -> ItemFloor assertSparseItems m =-  assert (EM.null (EM.filter EM.null m) `blame` m) m+  assert (EM.null (EM.filter EM.null m) `blame` "null floors found" `with` m) m  instance Binary Level where   put Level{..} = do@@ -174,15 +175,16 @@ accessibleDir :: Kind.COps -> Level -> Point -> Vector -> Bool accessibleDir cops lvl spos dir = accessible cops lvl spos $ spos `shift` dir -hideTile :: Kind.Ops TileKind -> Point -> Level -> Kind.Id TileKind-hideTile cotile p lvl =+isSecretPos :: Level -> Point -> Bool+isSecretPos lvl p =+  (lsecret lvl `Bits.rotateR` fromEnum p `Bits.xor` fromEnum p)+  `mod` lhidden lvl == 0++hideTile :: Kind.Ops TileKind -> Level -> Point -> Kind.Id TileKind+hideTile cotile lvl p =   let t = lvl `at` p-      ht = Tile.hiddenAs cotile t  -- TODO; tabulate with Speedup?-  in if ht == t-        || (lsecret lvl `Bits.rotateR` fromEnum p `Bits.xor` fromEnum p)-           `mod` lhidden lvl == 0-     then ht-     else t+      ht = Tile.hideAs cotile t  -- TODO; tabulate with Speedup?+  in if isSecretPos lvl p then ht else t  -- | Find a random position on the map satisfying a predicate. findPos :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point
Game/LambdaHack/Common/Misc.hs view
@@ -11,6 +11,8 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Functor+import qualified Data.Hashable as Hashable+import qualified Data.HashMap.Strict as HM import Data.Key import Data.Text (Text) import Data.Traversable (traverse)@@ -48,6 +50,11 @@   put m = put (ES.size m) >> mapM_ put (ES.toAscList m)   get = liftM ES.fromDistinctAscList get +instance (Binary k, Binary v, Eq k, Hashable.Hashable k)+  => Binary (HM.HashMap k v) where+  put ir = put $ HM.toList ir+  get = fmap HM.fromList get+ -- Data.Key  type instance Key (EM.EnumMap k) = k@@ -87,7 +94,7 @@  -- | Abstract level identifiers. newtype LevelId = LevelId Int-  deriving (Show, Eq, Ord, Enum, Read)+  deriving (Show, Eq, Ord, Enum)  instance Binary LevelId where   put (LevelId n) = put n
Game/LambdaHack/Common/Msg.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Game messages displayed on top of the screen for the player to read. module Game.LambdaHack.Common.Msg   ( makePhrase, makeSentence@@ -20,13 +20,17 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import Game.LambdaHack.Utils.Assert-import NLP.Miniutter.English (showT, (<+>), (<>))+import NLP.Miniutter.English ((<+>), (<>)) import qualified NLP.Miniutter.English as MU+import qualified Text.Show.Pretty as Show.Pretty  import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.PointXY +-- Pretty print and pack the result of @show@.+showT :: Show a => a -> Text+showT x = T.pack $ Show.Pretty.ppShow x+ -- | Re-exported English phrase creation functions, applied to default -- irregular word sets. makePhrase, makeSentence :: [MU.Part] -> Text@@ -197,7 +201,7 @@ -- prefixed by @msg@ and postfixed by @moreMsg@ except for the last one, -- fits on the screen wrt height (but lines may still be too wide). splitOverlay :: Y -> Overlay -> Overlay -> Slideshow-splitOverlay lysize msg ls = assert (length msg <= lysize) $+splitOverlay lysize msg ls =   let over = msg ++ ls   in if length over <= lysize + 2      then Slideshow [over]  -- all fits on one screen
Game/LambdaHack/Common/Perception.hs view
@@ -1,9 +1,25 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Actors perceiving other actors and the dungeon level.+--+-- Visibility works according to KISS. Everything that player sees is real.+-- There are no unmarked hidden tiles and only solid tiles can be marked,+-- so there are no invisible walls and to pass through an illusory wall,+-- you have use a turn bumping into it first. Only tiles marked with Suspect+-- can turn out to be another tile. (So, if all tiles are marked with+-- Suspect, the player knows nothing for sure, but this should be avoided,+-- because searching becomes too time-consuming.)+-- Each actor sees adjacent tiles, even when blind, so adjacent tiles are+-- known, so the actor can decide accurately whether to pass thorugh+-- or alter, etc.+--+-- Items are always real and visible. Actors are real, but can be invisible.+-- Invisible actors in walls can't be hit, but are hinted at when altering+-- the tile, so the player can flee or block. Invisible actors in open+-- space can be hit. module Game.LambdaHack.Common.Perception   ( Perception(..), PerceptionVisible(..), PerActor   , totalVisible, smellVisible-  , actorSeesLoc, nullPer, addPer, diffPer, smellFromActors+  , actorSeesPos, nullPer, addPer, diffPer, smellFromActors   , FactionPers, Pers   ) where @@ -33,9 +49,9 @@ -- of a given faction on the level and serves only as a speedup. -- The fields are not strict because often not all are used. data Perception = Perception-  { perActor :: PerActor           -- ^ visible points for each actor-  , ptotal   :: PerceptionVisible  -- ^ sum over all actors-  , psmell   :: PerceptionVisible  -- ^ sum over actors that can smell+  { perActor :: !PerActor           -- ^ visible points for each actor+  , ptotal   :: !PerceptionVisible  -- ^ sum over all actors+  , psmell   :: !PerceptionVisible  -- ^ sum over actors that can smell   }   deriving (Show, Eq, Generic) @@ -57,8 +73,8 @@ smellVisible = pvisible . psmell  -- | Whether an actor can see a position.-actorSeesLoc :: Perception -> ActorId -> Point -> Bool-actorSeesLoc per aid pos =+actorSeesPos :: Perception -> ActorId -> Point -> Bool+actorSeesPos per aid pos =   let isIn = (pos `ES.member`) . pvisible      -- Blind and non-smelling actors don't see their own pos, hence False.   in maybe False isIn $ EM.lookup aid $ perActor per
Game/LambdaHack/Common/Point.hs view
@@ -48,13 +48,14 @@ -- | Conversion from cartesian coordinates to @Point@. toPoint :: X -> PointXY -> Point toPoint lxsize (PointXY (x, y)) =-  assert (lxsize > x && x >= 0 && y >= 0 `blame` (lxsize, x, y))+  assert (lxsize > x && x >= 0 && y >= 0 `blame` "invalid point coordinates"+                                         `with` (lxsize, x, y))   $ Point $ x + y * lxsize  -- | Conversion from @Point@ to cartesian coordinates. fromPoint :: X -> Point -> PointXY fromPoint lxsize (Point p) =-  assert (p >= 0 `blame` (lxsize, p))+  assert (p >= 0 `blame` "negative point value" `with` (lxsize, p))   $ PointXY (p `rem` lxsize, p `quot` lxsize)  -- | The top-left corner position of the level.
Game/LambdaHack/Common/PointXY.hs view
@@ -40,7 +40,8 @@  let result        | x0 == x1 = L.map (\ y -> PointXY (x0, y)) (fromTo1 y0 y1)        | y0 == y1 = L.map (\ x -> PointXY (x, y0)) (fromTo1 x0 x1)-       | otherwise = assert `failure` ((x0, y0), (x1, y1))+       | otherwise = assert `failure` "diagononal fromTo"+                            `with` ((x0, y0), (x1, y1))  in result  fromTo1 :: Int -> Int -> [Int]
Game/LambdaHack/Common/Random.hs view
@@ -4,13 +4,13 @@   ( -- * The @Rng@ monad     Rnd     -- * Random operations-  , randomR, random, oneOf, frequency, roll-    -- * Rolling dice-  , RollDice(..), rollDice, maxDice, minDice, meanDice-    -- * Rolling 2D coordinates-  , RollDiceXY(..), rollDiceXY-    -- * Rolling dependent on depth-  , RollDeep, rollDeep, chanceDeep, intToDeep, maxDeep+  , randomR, random, oneOf, frequency, cast+    -- * Casting dice+  , RollDice, rollDice, castDice, maxDice, minDice, meanDice+    -- * Casting 2D coordinates+  , RollDiceXY(..), castDiceXY+    -- * Casting dependent on depth+  , RollDeep, castDeep, chanceDeep, intToDeep, maxDeep     -- * Fractional chance   , Chance, chance     -- * Run using the IO RNG@@ -44,6 +44,7 @@  -- | Get any element of a list with equal probability. oneOf :: [a] -> Rnd a+oneOf [] = assert `failure` "oneOf []" `with` () oneOf xs = do   r <- randomR (0, length xs - 1)   return (xs !! r)@@ -52,13 +53,13 @@ frequency :: Show a => Frequency a -> Rnd a frequency fr = St.state $ rollFreq fr --- | Roll a single die.-roll :: Int -> Rnd Int-roll x = if x <= 0 then return 0 else randomR (1, x)+-- | Cast a single die.+cast :: Int -> Rnd Int+cast x = if x <= 0 then return 0 else randomR (1, x)  -- | Dice: 1d7, 3d3, 1d0, etc. -- @RollDice a b@ represents @a@ rolls of @b@-sided die.-data RollDice = RollDice Binary.Word8 Binary.Word8+data RollDice = RollDice !Binary.Word8 !Binary.Word8   deriving (Eq, Ord, Generic)  instance Show RollDice where@@ -76,12 +77,17 @@  instance Binary RollDice --- | Roll dice and sum the results.-rollDice :: RollDice -> Rnd Int-rollDice (RollDice a' 1)  = return $ fromEnum a'  -- optimization-rollDice (RollDice a' b') =+rollDice :: Int -> Int -> RollDice+rollDice a b = assert (a >= 0 && a <= 255 && b >= 0 && b <= 255+                       `blame` "dice out of bounds" `with` (a, b))+               $ RollDice (toEnum a) (toEnum b)++-- | Cast dice and sum the results.+castDice :: RollDice -> Rnd Int+castDice (RollDice a' 1)  = return $ fromEnum a'  -- optimization+castDice (RollDice a' b') =   let (a, b) = (fromEnum a', fromEnum b')-  in liftM sum (replicateM a (roll b))+  in liftM sum (replicateM a (cast b))  -- | Maximal value of dice. maxDice :: RollDice -> Int@@ -103,14 +109,14 @@  -- | Dice for rolling a pair of integer parameters pertaining to, -- respectively, the X and Y cartesian 2D coordinates.-data RollDiceXY = RollDiceXY (RollDice, RollDice)+data RollDiceXY = RollDiceXY !(RollDice, RollDice)   deriving Show --- | Roll the two sets of dice.-rollDiceXY :: RollDiceXY -> Rnd (Int, Int)-rollDiceXY (RollDiceXY (xd, yd)) = do-  x <- rollDice xd-  y <- rollDice yd+-- | Cast the two sets of dice.+castDiceXY :: RollDiceXY -> Rnd (Int, Int)+castDiceXY (RollDiceXY (xd, yd)) = do+  x <- castDice xd+  y <- castDice yd   return (x, y)  -- | Dice for parameters scaled with current level depth.@@ -118,20 +124,25 @@ -- scaled in proportion to current depth divided by maximal dungeon depth. type RollDeep = (RollDice, RollDice) --- | Roll dice scaled with current level depth.+-- | Cast dice scaled with current level depth. -- Note that at the first level, the scaled dice are always ignored.-rollDeep :: Int -> Int -> RollDeep -> Rnd Int-rollDeep n depth (d1, d2) =-  assert (n > 0 && n <= depth `blame` (n, depth)) $ do-  r1 <- rollDice d1-  r2 <- rollDice d2+castDeep :: Int -> Int -> RollDeep -> Rnd Int+castDeep n' depth' (d1, d2) = do+  let n = abs n'+      depth = abs depth'+  assert (n > 0 && n <= depth `blame` "invalid current depth for dice rolls"+                              `with` (n, depth)) skip+  r1 <- castDice d1+  r2 <- castDice d2   return $ r1 + ((n - 1) * r2) `div` max 1 (depth - 1) --- | Roll dice scaled with current level depth and return @True@+-- | Cast dice scaled with current level depth and return @True@ -- if the results if greater than 50. chanceDeep :: Int -> Int -> RollDeep -> Rnd Bool-chanceDeep n depth deep = do-  c <- rollDeep n depth deep+chanceDeep n' depth' deep = do+  let n = abs n'+      depth = abs depth'+  c <- castDeep n depth deep   return $ c > 50  -- | Generate a @RollDeep@ that always gives a constant integer.@@ -139,7 +150,7 @@ intToDeep 0  = (RollDice 0 0, RollDice 0 0) intToDeep n' = let n = toEnum n'                in if n > maxBound || n < minBound-                  then assert `failure` n'+                  then assert `failure` "Deep out of bound" `with` n'                   else (RollDice n 1, RollDice 0 0)  -- | Maximal value of scaled dice.
+ Game/LambdaHack/Common/Save.hs view
@@ -0,0 +1,112 @@+-- | Saving and restoring server game state.+module Game.LambdaHack.Common.Save+  ( ChanSave, saveToChan, wrapInSaves, restoreGame, delayPrint+  ) where++import Control.Concurrent+import qualified Control.Exception as Ex hiding (handle)+import Control.Monad+import Data.Binary+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Directory+import System.FilePath+import System.IO+import qualified System.Random as R++import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Utils.File+import Game.LambdaHack.Utils.Thread++type ChanSave a = MVar (Maybe a)++saveToChan :: ChanSave a -> a -> IO ()+saveToChan toSave s = do+  -- Wipe out previous candidates for saving.+  void $ tryTakeMVar toSave+  putMVar toSave $ Just s++-- TODO: to have crash saves, send state to server save channel each turn+-- and have another mvar, asking for a save with the last state;+-- this mvar is permanently true on clients, but only set on server+-- in finally and each time bkp save is requested; finally should also+-- send save request to all clients (using the last state from the save+-- channel for client connection data, etc.)+-- All this is not needed if we bkp save each turn, but that's costly.++-- | Repeatedly save a simple serialized version of the current state.+loopSave :: Binary a => (a -> FilePath) -> ChanSave a -> IO ()+loopSave saveFile toSave =+  loop+ where+  loop = do+    -- Wait until anyting to save.+    ms <- takeMVar toSave+    case ms of+      Just s -> do+        encodeEOF (saveFile s) s+        -- Wait until the save finished. During that time, the mvar+        -- is continually updated to newest state values.+        loop+      Nothing -> return ()  -- exit++wrapInSaves :: Binary a => (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()+wrapInSaves saveFile exe = do+  -- We don't merge this with the other calls to waitForChildren,+  -- because, e.g., for server, we don't want to wait for clients to exit,+  -- if the server crashes (but we wait for the save to finish).+  children <- newMVar []+  toSave <- newEmptyMVar+  void $ forkChild children $ loopSave saveFile toSave+  let fin = do+        -- Wait until the last save (if any) starts+        -- and tell the save thread to end.+        putMVar toSave Nothing+        -- Wait until the save thread ends.+        waitForChildren children+  exe toSave `Ex.finally` fin+  -- The creation of, e.g., the initial client state, is outside the 'finally'+  -- clause, but this is OK, since no saves are ordered until 'runActionCli'.+  -- We save often, not only in the 'finally' section, in case of+  -- power outages, kill -9, GHC runtime crashes, etc. For internal game+  -- crashes, C-c, etc., the finalizer would be enough.+  -- If we implement incremental saves, saving often will help+  -- to spread the cost, to avoid a long pause at game exit.++-- | Restore a saved game, if it exists. Initialize directory structure+-- and cope over data files, if needed.+restoreGame :: Binary a+            => String -> FilePath+            -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath)+            -> IO (Maybe a)+restoreGame name configAppDataDir copies pathsDataFile = do+  -- Create user data directory and copy files, if not already there.+  tryCreateDir configAppDataDir+  tryCopyDataFiles pathsDataFile copies+  let saveFile = configAppDataDir </> name+  saveExists <- doesFileExist saveFile+  -- If the savefile exists but we get IO or decoding errors,+  -- we show them and start a new game. If the savefile was randomly+  -- corrupted or made read-only, that should solve the problem.+  -- OTOH, serious IO problems (e.g. failure to create a user data directory)+  -- terminate the program with an exception.+  res <- Ex.try $+    if saveExists then do+      s <- strictDecodeEOF saveFile+      return $ Just s+    else return Nothing+  let handler :: Ex.SomeException -> IO (Maybe a)+      handler e = do+        let msg = "Restore failed. The error message is:"+                  <+> (T.unwords . T.lines) (showT e)+        delayPrint $ msg+        return Nothing+  either handler return res++delayPrint :: Text -> IO ()+delayPrint t = do+  delay <- R.randomRIO (0, 1000000)+  threadDelay delay  -- try not to interleave letters with other clients+  T.hPutStrLn stderr t+  hFlush stderr
Game/LambdaHack/Common/ServerCmd.hs view
@@ -2,41 +2,59 @@ -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Common.ServerCmd-  ( CmdSer(..), aidCmdSer+  ( CmdSer(..), CmdSerTakeTime(..), aidCmdSer, aidCmdSerTakeTime+  , FailureSer(..), showFailureSer   ) where  import Data.Text (Text)  import Game.LambdaHack.Common.Actor+import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Vector  -- | Abstract syntax of server commands. data CmdSer =-    MoveSer ActorId Vector-  | ExploreSer ActorId Vector-  | RunSer ActorId Vector-  | WaitSer ActorId-  | PickupSer ActorId ItemId Int InvChar-  | DropSer ActorId ItemId-  | ProjectSer ActorId Point Int ItemId Container-  | ApplySer ActorId ItemId Container-  | TriggerSer ActorId Point-  | SetPathSer ActorId [Vector]-  | GameRestartSer ActorId Text-  | GameExitSer ActorId-  | GameSaveSer ActorId-  | CfgDumpSer ActorId-  deriving (Show)+    TakeTimeSer !CmdSerTakeTime+  | GameRestartSer !ActorId !Text+  | GameExitSer !ActorId+  | GameSaveSer !ActorId+  | CfgDumpSer !ActorId+  deriving (Show, Eq) --- | The actor performing the command, if still alive afterwards.+data CmdSerTakeTime =+    MoveSer !ActorId !Vector+  | MeleeSer !ActorId !ActorId+  | DisplaceSer !ActorId !ActorId+  | AlterSer !ActorId !Point !(Maybe F.Feature)+  | WaitSer !ActorId+  | PickupSer !ActorId !ItemId !Int !InvChar+  | DropSer !ActorId !ItemId+  | ProjectSer !ActorId !Point !Int !ItemId !Container+  | ApplySer !ActorId !ItemId !Container+  | TriggerSer !ActorId !(Maybe F.Feature)+  | SetPathSer !ActorId ![Vector]+  deriving (Show, Eq)++-- | The actor that start performing the command (may be dead, after+-- the command is performed). aidCmdSer :: CmdSer -> ActorId aidCmdSer cmd = case cmd of+  TakeTimeSer cmd2 -> aidCmdSerTakeTime cmd2+  GameRestartSer aid _ -> aid+  GameExitSer aid -> aid+  GameSaveSer aid -> aid+  CfgDumpSer aid -> aid++aidCmdSerTakeTime :: CmdSerTakeTime -> ActorId+aidCmdSerTakeTime cmd = case cmd of   MoveSer aid _ -> aid-  ExploreSer aid _ -> aid-  RunSer aid _ -> aid+  MeleeSer aid _ -> aid+  DisplaceSer aid _ -> aid+  AlterSer aid _ _ -> aid   WaitSer aid -> aid   PickupSer aid _ _ _ -> aid   DropSer aid _ -> aid@@ -44,7 +62,34 @@   ApplySer aid _ _ -> aid   TriggerSer aid _ -> aid   SetPathSer aid _ -> aid-  GameRestartSer aid _ -> aid-  GameExitSer aid -> aid-  GameSaveSer aid -> aid-  CfgDumpSer aid -> aid++data FailureSer =+    MoveNothing+  | MeleeDistant+  | DisplaceDistant+  | DisplaceAccess+  | AlterDistant+  | AlterBlockActor+  | AlterBlockItem+  | AlterNothing+  | ProjectAimOnself+  | ProjectBlockTerrain+  | ProjectBlockActor+  | ProjectBlockFoes+  | TriggerNothing++showFailureSer :: FailureSer -> Msg+showFailureSer failureSer = case failureSer of+  MoveNothing -> "wasting time on moving into obstacle"+  MeleeDistant -> "trying to melee a distant foe"+  DisplaceDistant -> "trying to switch places with a distant actor"+  DisplaceAccess -> "switching places without access"+  AlterDistant -> "trying to alter a distant tile"+  AlterBlockActor -> "blocked by an actor"+  AlterBlockItem -> "jammed by an item"+  AlterNothing -> "wasting time on altering nothing"+  ProjectAimOnself -> "cannot aim at oneself"+  ProjectBlockTerrain -> "aiming obstructed by terrain"+  ProjectBlockActor -> "aiming blocked by an actor"+  ProjectBlockFoes -> "aiming interrupted by foes"+  TriggerNothing -> "wasting time on triggering nothing"
Game/LambdaHack/Common/State.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Server and client game state types and operations. module Game.LambdaHack.Common.State   ( -- * Basic game state, local or global@@ -9,7 +8,7 @@   , defStateGlobal, emptyState, localFromGlobal   , updateDungeon, updateDepth, updateActorD, updateItemD   , updateFaction, updateTime, updateCOps, getLocalTime-  , isHumanFaction, usesAIFaction, isSpawnFaction, isSummonFaction+  , isSpawnFaction, isSummonFaction   ) where  import Data.Binary@@ -44,9 +43,10 @@ -- TODO: add a flag 'fresh' and when saving levels, don't save -- and when loading regenerate this level. unknownLevel :: Kind.Ops TileKind -> Int -> X -> Y-             -> Text -> (Point, Point) -> Int+             -> Text -> ([Point], [Point]) -> Int -> Int -> Int              -> Level-unknownLevel Kind.Ops{ouniqGroup} ldepth lxsize lysize ldesc lstair lclear =+unknownLevel Kind.Ops{ouniqGroup} ldepth lxsize lysize ldesc lstair lclear+             lsecret lhidden =   let unknownId = ouniqGroup "unknown space"   in Level { ldepth            , lprio = EM.empty@@ -59,10 +59,10 @@            , lstair            , lseen = 0            , lclear-           , ltime = timeZero+           , ltime = timeTurn            , litemNum = 0-           , lsecret = 0  -- unkown by clients-           , lhidden = 0  -- unkown by clients+           , lsecret+           , lhidden            }  unknownTileMap :: Kind.Id TileKind -> Int -> Int -> TileMap@@ -78,7 +78,7 @@   State     { _sactorD = EM.empty     , _sitemD = EM.empty-    , _stime = timeZero+    , _stime = timeTurn     , ..     } @@ -91,7 +91,7 @@     , _sactorD = EM.empty     , _sitemD = EM.empty     , _sfactionD = EM.empty-    , _stime = timeZero+    , _stime = timeTurn     , _scops = undefined     , _shigh = HighScore.empty     }@@ -105,8 +105,9 @@ localFromGlobal State{_scops=_scops@Kind.COps{cotile}, .. } =   State     { _sdungeon =-      EM.map (\Level{ldepth, lxsize, lysize, ldesc, lstair, lclear} ->-              unknownLevel cotile ldepth lxsize lysize ldesc lstair lclear)+      EM.map (\Level{..} ->+              unknownLevel cotile ldepth lxsize lysize ldesc lstair lclear+                           lsecret lhidden)             _sdungeon     , ..     }@@ -142,14 +143,6 @@ -- | Get current time from the dungeon data. getLocalTime :: LevelId -> State -> Time getLocalTime lid s = ltime $ _sdungeon s EM.! lid---- | Tell whether the faction is controlled (at least partially) by a human.-isHumanFaction :: FactionId -> State -> Bool-isHumanFaction fid s = isHumanFact $ _sfactionD s EM.! fid---- | Tell whether the faction uses AI to control any of its actors.-usesAIFaction :: FactionId -> State -> Bool-usesAIFaction fid s = usesAIFact $ _sfactionD s EM.! fid  -- | Tell whether the faction can spawn actors. isSpawnFaction :: FactionId -> State -> Bool
Game/LambdaHack/Common/Tile.hs view
@@ -16,17 +16,18 @@   ( SmellTime   , kindHasFeature, kindHas, hasFeature   , isClear, isLit, isExplorable, similar, speedup-  , changeTo, hiddenAs+  , openTo, closeTo, revealAs, hideAs, openable, closable, changeable   ) where  import qualified Data.Array.Unboxed as A import qualified Data.List as L -import Game.LambdaHack.Content.TileKind import qualified Game.LambdaHack.Common.Feature as F import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Utils.Assert  -- | The last time a hero left a smell in a given tile. To be used -- by monsters that hunt by smell.@@ -50,20 +51,19 @@ -- | Whether a tile does not block vision. -- Essential for efficiency of "FOV", hence tabulated. isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isClear Kind.Ops{ospeedup = Kind.TileSpeedup{isClearTab}} = isClearTab+isClear Kind.Ops{ospeedup = Just Kind.TileSpeedup{isClearTab}} = isClearTab+isClear cotile = assert `failure` "no speedup" `with` Kind.obounds cotile  -- | Whether a tile is lit on its own. -- Essential for efficiency of "Perception", hence tabulated. isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isLit Kind.Ops{ospeedup = Kind.TileSpeedup{isLitTab}} = isLitTab+isLit Kind.Ops{ospeedup = Just Kind.TileSpeedup{isLitTab}} = isLitTab+isLit cotile = assert `failure` "no speedup" `with` Kind.obounds cotile  -- | Whether a tile can be explored, possibly yielding a treasure--- or a hidden message. We exclude doors and hidden features.+-- or a hidden message. isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isExplorable cops tk =-  not (hasFeature cops F.Closable tk)-  && (isClear cops tk-      || hasFeature cops F.Walkable tk)+isExplorable cops tk = isClear cops tk || hasFeature cops F.Walkable tk  -- | The player can't tell one tile from the other. similar :: TileKind -> TileKind -> Bool@@ -87,18 +87,61 @@       isLitTab   = tabulate $ kindHasFeature F.Lit   in Kind.TileSpeedup {isClearTab, isLitTab} -changeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)-changeTo Kind.Ops{okind, opick} t =-  let getTo (F.ChangeTo group) _ = Just group+openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)+openTo Kind.Ops{okind, opick} t = do+  let getTo (F.OpenTo group) acc = group : acc       getTo _ acc = acc-  in case foldr getTo Nothing (tfeature (okind t)) of-       Nothing    -> return t-       Just group -> opick group (const True)+  case foldr getTo [] $ tfeature $ okind t of+    [] -> return t+    groups -> do+      group <- oneOf groups+      opick group (const True) -hiddenAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind-hiddenAs Kind.Ops{okind, ouniqGroup} t =-  let getTo (F.HiddenAs group) _ = Just group+closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)+closeTo Kind.Ops{okind, opick} t = do+  let getTo (F.CloseTo group) acc = group : acc       getTo _ acc = acc+  case foldr getTo [] $ tfeature $ okind t of+    [] -> return t+    groups -> do+      group <- oneOf groups+      opick group (const True)++revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)+revealAs Kind.Ops{okind, opick} t = do+  let getTo (F.RevealAs group) acc = group : acc+      getTo _ acc = acc+  case foldr getTo [] $ tfeature $ okind t of+    [] -> return t+    groups -> do+      group <- oneOf groups+      opick group (const True)++hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind+hideAs Kind.Ops{okind, ouniqGroup} t =+  let getTo (F.HideAs group) _ = Just group+      getTo _ acc = acc   in case foldr getTo Nothing (tfeature (okind t)) of        Nothing    -> t        Just group -> ouniqGroup group++-- | Whether a tile kind (specified by its id) has a OpenTo feature.+openable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+openable Kind.Ops{okind} t =+  let getTo F.OpenTo{} = True+      getTo _ = False+  in any getTo $ tfeature $ okind t++-- | Whether a tile kind (specified by its id) has a CloseTo feature.+closable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+closable Kind.Ops{okind} t =+  let getTo F.CloseTo{} = True+      getTo _ = False+  in any getTo $ tfeature $ okind t++-- | Whether a tile kind (specified by its id) has a ChangeTo feature.+changeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+changeable Kind.Ops{okind} t =+  let getTo F.ChangeTo{} = True+      getTo _ = False+  in any getTo $ tfeature $ okind t
Game/LambdaHack/Common/Vector.hs view
@@ -48,7 +48,8 @@ -- | Converts a unit vector in cartesian representation into @Vector@. toDir :: X -> VectorXY -> Vector toDir lxsize v@(VectorXY (x, y)) =-  assert (lxsize >= 3 && isUnitXY v `blame` (lxsize, v)) $+  assert (lxsize >= 3 && isUnitXY v `blame` "ambiguous XY vector conversion"+                                    `with` (lxsize, v)) $   Vector $ x + y * lxsize  -- | Converts a unit vector in the offset representation@@ -58,7 +59,7 @@ fromDir lxsize (Vector dir) =   assert (lxsize >= 3 && isUnitXY res &&           fst len1 + snd len1 * lxsize == dir-          `blame` (lxsize, dir, res))+          `blame` "ambiguous vector conversion" `with` (lxsize, dir, res))   res  where   (x, y) = (dir `mod` lxsize, dir `div` lxsize)@@ -109,19 +110,22 @@ -- (in the euclidean metric) maximally align with the original vector. normalize :: X -> VectorXY -> Vector normalize lxsize v@(VectorXY (dx, dy)) =-  assert (dx /= 0 || dy /= 0 `blame` (dx, dy)) $+  assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `with` (dx, dy)) $   let angle :: Double       angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)-      dxy | angle <= -0.75 = (0, -1)+      dxy | angle <= -0.75 && angle >= -1.25 = (0, -1)           | angle <= -0.25 = (1, -1)           | angle <= 0.25  = (1, 0)           | angle <= 0.75  = (1, 1)           | angle <= 1.25  = (0, 1)-          | otherwise = assert `failure` (lxsize, dx, dy, angle)+          | otherwise = assert `failure` "impossible angle"+                               `with` (lxsize, dx, dy, angle)       rxy = if dx >= 0             then VectorXY dxy             else negXY $ VectorXY dxy-  in assert (not (isUnitXY v) || v == rxy `blame` (v, rxy))+  in assert (not (isUnitXY v) || v == rxy+             `blame` "unit vector gets untrivially normalized"+             `with` (v, rxy))      $ toDir lxsize rxy  -- TODO: Perhaps produce all acceptable directions and let AI choose.@@ -136,7 +140,7 @@ -- the two points. towards :: X -> Point -> Point -> Vector towards lxsize pos0 pos1 =-  assert (pos0 /= pos1 `blame` (pos0, pos1)) $+  assert (pos0 /= pos1 `blame` "towards self" `with` (pos0, pos1)) $   let v = displacementXYZ lxsize pos0 pos1   in normalize lxsize v
Game/LambdaHack/Content/ActorKind.hs view
@@ -4,7 +4,7 @@   ) where  import Control.Arrow ((&&&))-import qualified Data.List as L+import Data.List import qualified Data.Ord as Ord import Data.Text (Text) @@ -39,6 +39,6 @@ avalidate l =   let cmp = Ord.comparing $ asymbol &&& acolor       eq ka1 ka2 = cmp ka1 ka2 == Ord.EQ-      sorted = L.sortBy cmp l-      nubbed = L.nubBy eq sorted-  in L.deleteFirstsBy eq sorted nubbed+      sorted = sortBy cmp l+      nubbed = nubBy eq sorted+  in deleteFirstsBy eq sorted nubbed
Game/LambdaHack/Content/CaveKind.hs view
@@ -13,27 +13,27 @@  -- | Parameters for the generation of dungeon levels. data CaveKind = CaveKind-  { csymbol         :: Char        -- ^ a symbol-  , cname           :: Text        -- ^ short description-  , cfreq           :: Freqs       -- ^ frequency within groups-  , cxsize          :: X           -- ^ X size of the whole cave-  , cysize          :: Y           -- ^ Y size of the whole cave-  , cgrid           :: RollDiceXY  -- ^ the dimensions of the grid of places-  , cminPlaceSize   :: RollDiceXY  -- ^ minimal size of places-  , cdarkChance     :: RollDeep    -- ^ the chance a place is dark-  , cauxConnects    :: Rational    -- ^ a proportion of extra connections-  , cvoidChance     :: Chance      -- ^ the chance of not creating a place-  , cnonVoidMin     :: Int         -- ^ extra places, may overlap except two-  , cminStairDist   :: Int         -- ^ minimal distance between stairs-  , cdoorChance     :: Chance      -- ^ the chance of a door in an opening-  , copenChance     :: Chance      -- ^ if there's a door, is it open?-  , chidden         :: Int         -- ^ if not open, hidden one in n times-  , citemNum        :: RollDice    -- ^ the number of items in the cave-  , cdefTile        :: Text        -- ^ the default cave tile group name-  , ccorridorTile   :: Text        -- ^ the cave corridor tile group name-  , cfillerTile     :: Text        -- ^ the filler wall group name-  , cdarkLegendTile :: Text        -- ^ the dark place plan legend ground name-  , clitLegendTile  :: Text        -- ^ the lit place plan legend ground name+  { csymbol         :: !Char        -- ^ a symbol+  , cname           :: !Text        -- ^ short description+  , cfreq           :: !Freqs       -- ^ frequency within groups+  , cxsize          :: !X           -- ^ X size of the whole cave+  , cysize          :: !Y           -- ^ Y size of the whole cave+  , cgrid           :: !RollDiceXY  -- ^ the dimensions of the grid of places+  , cminPlaceSize   :: !RollDiceXY  -- ^ minimal size of places+  , cdarkChance     :: !RollDeep    -- ^ the chance a place is dark+  , cauxConnects    :: !Rational    -- ^ a proportion of extra connections+  , cvoidChance     :: !Chance      -- ^ the chance of not creating a place+  , cnonVoidMin     :: !Int         -- ^ extra places, may overlap except two+  , cminStairDist   :: !Int         -- ^ minimal distance between stairs+  , cdoorChance     :: !Chance      -- ^ the chance of a door in an opening+  , copenChance     :: !Chance      -- ^ if there's a door, is it open?+  , chidden         :: !Int         -- ^ if not open, hidden one in n times+  , citemNum        :: !RollDice    -- ^ the number of items in the cave+  , cdefTile        :: !Text        -- ^ the default cave tile group name+  , ccorridorTile   :: !Text        -- ^ the cave corridor tile group name+  , cfillerTile     :: !Text        -- ^ the filler wall group name+  , cdarkLegendTile :: !Text        -- ^ the dark place plan legend ground name+  , clitLegendTile  :: !Text        -- ^ the lit place plan legend ground name   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53
Game/LambdaHack/Content/FactionKind.hs view
@@ -4,15 +4,16 @@   ) where  import Data.Text (Text)+import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Misc  -- | Faction properties that are fixed for a given kind of factions. data FactionKind = FactionKind-  { fsymbol   :: !Char     -- ^ a symbol-  , fname     :: !Text     -- ^ short description-  , ffreq     :: !Freqs    -- ^ frequency within groups-  , fAiLeader :: !Text     -- ^ AI to use for the selected actor-  , fAiMember :: !Text     -- ^ AI to use for idle actors+  { fsymbol        :: !Char       -- ^ a symbol+  , fname          :: !Text       -- ^ short description+  , ffreq          :: !Freqs      -- ^ frequency within groups+  , fAbilityLeader :: ![Ability]  -- ^ abilities of the selected actor+  , fAbilityOther  :: ![Ability]  -- ^ abilities of the other actors   }   deriving Show
Game/LambdaHack/Content/ItemKind.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | The type of kinds of weapons and treasure. module Game.LambdaHack.Content.ItemKind   ( ItemKind(..), ivalidate
+ Game/LambdaHack/Content/ModeKind.hs view
@@ -0,0 +1,79 @@+-- | The type of kinds of game modes.+module Game.LambdaHack.Content.ModeKind+  ( Caves, Players(..), Player(..), ModeKind(..), mvalidate+  ) where++import Data.Binary+import qualified Data.EnumMap.Strict as EM+import Data.Text (Text)+import NLP.Miniutter.English ()++import Game.LambdaHack.Common.Misc (Freqs, LevelId)++-- | Game mode specification.+data ModeKind = ModeKind+  { msymbol  :: !Char     -- ^ a symbol (matches the keypress, if any)+  , mname    :: !Text     -- ^ short description+  , mfreq    :: !Freqs    -- ^ frequency within groups+  , mplayers :: !Players  -- ^ players taking part in the game+  , mcaves   :: !Caves    -- ^ arena of the game+  }+  deriving Show++-- | Requested cave groups for particular levels. The default is+-- the "dng" group, which means a random choice from all caves+-- that can randomly appear. The second component of the pair+-- is the @Escape@ feature on the level. @True@ means it's represented+-- by @<@, @False@, by @>@.+type Caves = EM.EnumMap LevelId (Text, Maybe Bool)++-- | The specification of players for the game mode.+data Players = Players+  { playersList  :: ![Player]        -- ^ players, both human and computer+  , playersEnemy :: ![(Text, Text)]  -- ^ the initial enmity matrix+  , playersAlly  :: ![(Text, Text)]  -- ^ the initial aliance matrix+  }+  deriving (Show, Eq)++-- | Properties of a particular player.+data Player = Player+  { playerName     :: !Text     -- ^ name of the player+  , playerFaction  :: !Text     -- ^ name of faction(s) the player can control+  , playerEntry    :: !LevelId  -- ^ level where the initial members start+  , playerInitial  :: !Int      -- ^ number of initial members+  , playerAiLeader :: !Bool     -- ^ is the leader under AI control?+  , playerAiOther  :: !Bool     -- ^ are the others under AI control?+  , playerHuman    :: !Bool     -- ^ is the player considered human+                                -- and so, e.g., eligible for a high score?+  , playerUI       :: !Bool     -- ^ does the faction have a UI client+                                -- (for control or passive observation)+  }+  deriving (Show, Eq)++-- TODO: assert if no UI, both Ai are on and there are some non-spawners;+-- assert that playersEnemy and playersAlly mention only factions in play.+-- | No specific possible problems for the content of this kind, so far,+-- so the validation function always returns the empty list of offending kinds.+mvalidate :: [ModeKind] -> [ModeKind]+mvalidate _ = []++instance Binary Player where+  put Player{..} = do+    put playerName+    put playerFaction+    put playerEntry+    put playerInitial+    put playerAiLeader+    put playerAiOther+    put playerHuman+    put playerUI+  get = do+    playerName <- get+    playerFaction <- get+    playerEntry <- get+    playerInitial <- get+    playerAiLeader <- get+    playerAiOther <- get+    playerHuman <- get+    playerUI <- get+    return Player{..}
Game/LambdaHack/Content/PlaceKind.hs view
@@ -11,12 +11,12 @@  -- | Parameters for the generation of small areas within a dungeon level. data PlaceKind = PlaceKind-  { psymbol  :: Char      -- ^ a symbol-  , pname    :: Text      -- ^ short description-  , pfreq    :: Freqs     -- ^ frequency within groups-  , pcover   :: Cover     -- ^ how to fill whole place based on the corner-  , pfence   :: Fence     -- ^ whether to fence the place with solid border-  , ptopLeft :: [Text]    -- ^ plan of the top-left corner of the place+  { psymbol  :: !Char      -- ^ a symbol+  , pname    :: !Text      -- ^ short description+  , pfreq    :: !Freqs     -- ^ frequency within groups+  , pcover   :: !Cover     -- ^ how to fill whole place based on the corner+  , pfence   :: !Fence     -- ^ whether to fence the place with solid border+  , ptopLeft :: ![Text]    -- ^ plan of the top-left corner of the place   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53
Game/LambdaHack/Content/RuleKind.hs view
@@ -6,10 +6,10 @@ import Data.Text (Text) import Data.Version -import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.PointXY+import Game.LambdaHack.Content.TileKind  -- TODO: very few rules are configurable yet, extend as needed. @@ -27,18 +27,19 @@ -- whether one position is accessible from another. -- Precondition: the two positions are next to each other. data RuleKind = RuleKind-  { rsymbol          :: Char     -- ^ a symbol-  , rname            :: Text     -- ^ short description-  , rfreq            :: Freqs    -- ^ frequency within groups+  { rsymbol          :: !Char     -- ^ a symbol+  , rname            :: !Text     -- ^ short description+  , rfreq            :: !Freqs    -- ^ frequency within groups   , raccessible      :: X -> Point -> TileKind -> Point -> TileKind -> Bool-  , rtitle           :: Text     -- ^ the title of the game+  , rtitle           :: !Text     -- ^ the title of the game   , rpathsDataFile   :: FilePath -> IO FilePath  -- ^ the path to data files-  , rpathsVersion    :: Version  -- ^ the version of the game-  , ritemMelee       :: [Char]   -- ^ symbols of melee weapons-  , ritemProject     :: [Char]   -- ^ symbols of items AI can project-  , rcfgRulesDefault :: String   -- ^ the default game rules config file-  , rcfgUIDefault    :: String   -- ^ the default UI settings config file-  , rmainMenuArt     :: Text     -- ^ the ASCII art for the Main Menu+  , rpathsVersion    :: !Version  -- ^ the version of the game+  , ritemMelee       :: ![Char]   -- ^ symbols of melee weapons+  , ritemRanged      :: ![Char]   -- ^ symbols of ranged weapons and missiles+  , ritemProject     :: ![Char]   -- ^ symbols of items AI can project+  , rcfgRulesDefault :: !String   -- ^ the default game rules config file+  , rcfgUIDefault    :: !String   -- ^ the default UI settings config file+  , rmainMenuArt     :: !Text     -- ^ the ASCII art for the Main Menu   }  -- | A dummy instance of the 'Show' class, to satisfy general requirments
− Game/LambdaHack/Content/StrategyKind.hs 
@@ -1,23 +0,0 @@--- | The type of kinds of AI strategies.-module Game.LambdaHack.Content.StrategyKind-  ( StrategyKind(..), svalidate-  ) where--import Data.Text (Text)--import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Misc---- | Strategy properties that are fixed for a given kind of strategies.-data StrategyKind = StrategyKind-  { ssymbol    :: !Char       -- ^ a symbol-  , sname      :: !Text       -- ^ short description-  , sfreq      :: !Freqs      -- ^ frequency within groups-  , sabilities :: ![Ability]  -- ^ abilities to pick from in roughly that order-  }-  deriving Show---- | No specific possible problems for the content of this kind, so far,--- so the validation function always returns the empty list of offending kinds.-svalidate :: [StrategyKind] -> [StrategyKind]-svalidate _ = []
Game/LambdaHack/Content/TileKind.hs view
@@ -25,7 +25,9 @@   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53 +-- TODO: Make sure only solid tiles have Suspect. -- TODO: check that all posible solid place fences have hidden counterparts.+-- TODO: verify that OpenTo, CloseTo and ChangeTo are assigned as specified. -- | Filter a list of kinds, passing through only the incorrect ones, if any. -- -- If tiles look the same on the map, the description should be the same, too.@@ -43,10 +45,9 @@                                  , [kt] )) lt       mapFov :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind]       mapFov f = M.fromListWith (++) $ listFov f-      namesUnequal [] = assert `failure` lt-      namesUnequal (hd : tl) = let name = tname hd-                               -- Check that at least one is different.-                               in L.any (/= name) (L.map tname tl)+      namesUnequal [] = assert `failure` "no TileKind content" `with` lt+      namesUnequal (hd : tl) = -- Check that at least one is different.+                               L.any (/= tname hd) (L.map tname tl)       confusions f = L.filter namesUnequal $ M.elems $ mapFov f   in case confusions tcolor ++ confusions tcolor2 of     [] -> []
Game/LambdaHack/Frontend.hs view
@@ -1,11 +1,10 @@-{-# LANGUAGE OverloadedStrings #-} -- | Display game data on the screen and receive user input -- using one of the available raw frontends and derived  operations. module Game.LambdaHack.Frontend   ( -- * Re-exported part of the raw frontend     frontendName     -- * Derived operation-  , startupF, getConfirmGeneric+  , startupF     -- * Connection channels   , ChanFrontend, FrontReq(..), ConnMulti(..), connMulti, loopFrontend   ) where@@ -31,6 +30,7 @@  type ChanFrontend = TQueue K.KM +-- | The first component is the number of UI players at game start. type FromMulti = MVar (Int, FactionId -> (ChanFrontend, Text))  type ToMulti = TQueue (FactionId, FrontReq)@@ -40,7 +40,7 @@       -- ^ show a frame, if the fid acitve, or save it to the client's queue   | FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}       -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress-  | FrontSlides {frontClear :: [K.KM], frontSlides :: [SingleFrame]}+  | FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]}       -- ^ show a whole slideshow without interleaving with other clients  type ReqMap = EM.EnumMap FactionId (LQueue AcFrame)@@ -48,23 +48,28 @@ -- | Multiplex connection channels, for the case of a frontend shared -- among clients. This is transparent to the clients themselves. data ConnMulti = ConnMulti-  { fromMulti :: FromMulti-  , toMulti   :: ToMulti+  { fromMulti :: !FromMulti+  , toMulti   :: !ToMulti   } -startupF :: String -> IO () -> IO ()-startupF s k = startup s $ \fs -> do-  void $ forkIO $ loopFrontend fs connMulti-  k+startupF :: DebugModeCli -> IO () -> IO ()+startupF dbg cont =+  (if sfrontendStd dbg then stdStartup else chosenStartup) dbg $ \fs -> do+    void $ forkIO $ loopFrontend fs connMulti+    cont  -- | Display a prompt, wait for any of the specified keys (for any key, -- if the list is empty). Repeat if an unexpected key received.-promptGetKey :: FrontendSession -> [K.KM] -> SingleFrame -> IO K.KM-promptGetKey sess keys frame = do-  km <- promptGetAnyKey sess frame-  if null keys || km `elem` keys+promptGetKey :: Frontend -> [K.KM] -> SingleFrame -> IO K.KM+promptGetKey fs [] frame = fpromptGetKey fs frame+promptGetKey fs keys@(firstKM:_) frame = do+  km <- fpromptGetKey fs frame+  if km `elem` keys     then return km-    else promptGetKey sess keys frame+    else do+      let DebugModeCli{snoMore} = fdebugCli fs+      if snoMore then return firstKM+      else promptGetKey fs keys frame  -- TODO: avoid unsafePerformIO; but server state is a wrong idea, too connMulti :: ConnMulti@@ -80,22 +85,22 @@                   -> [K.KM] -> a -> m Bool getConfirmGeneric pGetKey clearKeys x = do   let extraKeys = [ K.KM {key=K.Space, modifier=K.NoModifier}-                  , K.KM {key=K.Esc, modifier=K.NoModifier} ]+                  , K.escKey ]   km <- pGetKey (clearKeys ++ extraKeys) x-  return $! km /= K.KM {key=K.Esc, modifier=K.NoModifier}+  return $! km /= K.escKey -flushFrames :: FrontendSession -> FactionId -> ReqMap -> IO ReqMap+flushFrames :: Frontend -> FactionId -> ReqMap -> IO ReqMap flushFrames fs fid reqMap = do   let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap       reqMap2 = EM.delete fid reqMap   mapM_ (displayAc fs) queue   return reqMap2 -displayAc :: FrontendSession -> AcFrame -> IO ()+displayAc :: Frontend -> AcFrame -> IO () displayAc fs (AcConfirm fr) = void $ getConfirmGeneric (promptGetKey fs) [] fr-displayAc fs (AcRunning fr) = display fs True (Just fr)-displayAc fs (AcNormal fr) = display fs False (Just fr)-displayAc fs AcDelay = display fs False Nothing+displayAc fs (AcRunning fr) = fdisplay fs True (Just fr)+displayAc fs (AcNormal fr) = fdisplay fs False (Just fr)+displayAc fs AcDelay = fdisplay fs False Nothing  getSingleFrame :: AcFrame -> Maybe SingleFrame getSingleFrame (AcConfirm fr) = Just fr@@ -108,7 +113,7 @@   let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap   in mapMaybe getSingleFrame queue -fadeF :: FrontendSession -> Bool -> FactionId -> Text -> SingleFrame -> IO ()+fadeF :: Frontend -> Bool -> FactionId -> Text -> SingleFrame -> IO () fadeF fs out side pname frame = do   let topRight = True       lxsize = xsizeSingleFrame frame@@ -124,7 +129,7 @@             -- Empty frame to mark the fade-in end,             -- to trim only to here if SPACE pressed.           | otherwise = animFrs ++ [Nothing]-  mapM_ (display fs False) frs+  mapM_ (fdisplay fs False) frs  insertFr :: FactionId -> AcFrame -> ReqMap -> ReqMap insertFr fid fr reqMap =@@ -136,7 +141,7 @@ -- There may be many UI clients, but this function is only ever -- executed on one thread, so the frontend receives requests -- in a sequential way, without any random interleaving.-loopFrontend :: FrontendSession -> ConnMulti -> IO ()+loopFrontend :: Frontend -> ConnMulti -> IO () loopFrontend fs ConnMulti{..} = loop Nothing EM.empty  where   writeKM :: FactionId -> K.KM -> IO ()@@ -153,7 +158,7 @@     if Just fid == fmap fst oldFidFrame then       return reqMap     else do-      (nH, fCT) <- readMVar fromMulti+      (nU, fCT) <- readMVar fromMulti       let pname = snd $ fCT fid       reqMap2 <- case oldFidFrame of         Nothing -> return reqMap@@ -165,8 +170,9 @@           return reqMap2       let singles = toSingles fid reqMap2           firstFrame = fromMaybe frontFr $ listToMaybe singles-      -- @nH@ is unreliable, except at the game start.-      unless (isNothing oldFidFrame && nH < 2) $+      -- TODO: @nU@ is unreliable, when some of UI players die;+      -- in the result a single players has unneeded fadeins.+      unless (isNothing oldFidFrame && nU < 2) $         fadeF fs False fid pname firstFrame       flushFrames fs fid reqMap2 @@ -190,18 +196,18 @@       FrontSlides{frontSlides = []} -> return ()       FrontSlides{frontSlides = frontSlides@(fr1 : _), ..} -> do         reqMap2 <- flushFade fr1 oldFidFrame reqMap fid-        let go frs =+        let displayFrs frs =               case frs of-                [] -> assert `failure` fid+                [] -> assert `failure` "null slides" `with` fid                 [x] -> do-                  display fs False (Just x)+                  fdisplay fs False (Just x)                   writeKM fid K.KM {key=K.Space, modifier=K.NoModifier}                   return x                 x : xs -> do-                  b <- getConfirmGeneric (promptGetKey fs) frontClear x-                  if b then go xs+                  go <- getConfirmGeneric (promptGetKey fs) frontClear x+                  if go then displayFrs xs                   else do-                    writeKM fid K.KM {key=K.Esc, modifier=K.NoModifier}+                    writeKM fid K.escKey                     return x-        frLast <- go frontSlides+        frLast <- displayFrs frontSlides         loop (Just (fid, frLast)) reqMap2
Game/LambdaHack/Frontend/Chosen.hs view
@@ -2,20 +2,49 @@ -- | Re-export the operations of the chosen raw frontend -- (determined at compile time with cabal flags). module Game.LambdaHack.Frontend.Chosen-  ( -- * Re-exported raw frontend-    FrontendSession, startup, frontendName, promptGetAnyKey, display+  ( Frontend(..), chosenStartup, stdStartup+  , frontendName   ) where --- Wrapper for selected Display frontend.+import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..))+import qualified Game.LambdaHack.Common.Key as K  #ifdef GTK-import Game.LambdaHack.Frontend.Gtk as D+import qualified Game.LambdaHack.Frontend.Gtk as Chosen #elif VTY-import Game.LambdaHack.Frontend.Vty as D+import qualified Game.LambdaHack.Frontend.Vty as Chosen #elif CURSES-import Game.LambdaHack.Frontend.Curses as D-#elif STD-import Game.LambdaHack.Frontend.Std as D+import qualified Game.LambdaHack.Frontend.Curses as Chosen #else-import Game.LambdaHack.Frontend.Gtk as D+import qualified Game.LambdaHack.Frontend.Gtk as Chosen #endif++import qualified Game.LambdaHack.Frontend.Std as Std++-- | The name of the chosen frontend.+frontendName :: String+frontendName = Chosen.frontendName++data Frontend = Frontend+  { fdisplay      :: Bool -> Maybe SingleFrame -> IO ()+  , fpromptGetKey :: SingleFrame -> IO K.KM+  , fdebugCli     :: !DebugModeCli+  }++chosenStartup :: DebugModeCli -> (Frontend -> IO ()) -> IO ()+chosenStartup fdebugCli cont =+  Chosen.startup fdebugCli $ \fs ->+    cont $ Frontend+      { fdisplay = Chosen.fdisplay fs+      , fpromptGetKey = Chosen.fpromptGetKey fs+      , fdebugCli+      }++stdStartup :: DebugModeCli -> (Frontend -> IO ()) -> IO ()+stdStartup fdebugCli cont =+  Std.startup fdebugCli $ \fs ->+    cont $ Frontend+      { fdisplay = Std.fdisplay fs+      , fpromptGetKey = Std.fpromptGetKey fs+      , fdebugCli+      }
Game/LambdaHack/Frontend/Curses.hs view
@@ -3,7 +3,7 @@   ( -- * Session data type for the frontend     FrontendSession     -- * The output and input operations-  , display, promptGetAnyKey+  , fdisplay, fpromptGetKey     -- * Frontend administration tools   , frontendName, startup   ) where@@ -16,17 +16,17 @@ import qualified UI.HSCurses.Curses as C import qualified UI.HSCurses.CursesHelper as C -import Game.LambdaHack.Common.Animation (SingleFrame (..))+import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K (KM (..), Key (..),-                                                  Modifier (..))+import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Utils.Assert  -- | Session data maintained by the frontend. data FrontendSession = FrontendSession-  { swin    :: C.Window  -- ^ the window to draw to-  , sstyles :: M.Map Color.Attr C.CursesStyle+  { swin      :: !C.Window  -- ^ the window to draw to+  , sstyles   :: !(M.Map Color.Attr C.CursesStyle)       -- ^ map from fore/back colour pairs to defined curses styles+  , sdebugCli :: !DebugModeCli  -- ^ client configuration   }  -- | The name of the frontend.@@ -34,8 +34,8 @@ frontendName = "curses"  -- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = do+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+startup sdebugCli k = do   C.start --  C.keypad C.stdScr False  -- TODO: may help to fix xterm keypad on Ubuntu   void $ C.cursSet C.CursorInvisible@@ -45,22 +45,21 @@             bg <- Color.legalBG ]   nr <- C.colorPairs   when (nr < L.length s) $-    C.end >>-    (assert `failure`-       "Terminal has too few color pairs (" ++ show nr ++ "). Giving up.")+    C.end >> (assert `failure` "terminal has too few color pairs" `with` nr)   let (ks, vs) = unzip s   ws <- C.convertStyles vs-  let styleMap = M.fromList (zip ks ws)-  k (FrontendSession C.stdScr styleMap)+  let swin = C.stdScr+      sstyles = M.fromList (zip ks ws)+  k FrontendSession{..}   C.end  -- | Output to the screen via the frontend.-display :: FrontendSession    -- ^ frontend session data-        -> Bool-        -> Maybe SingleFrame  -- ^ the screen frame to draw-        -> IO ()-display _ _ Nothing = return ()-display FrontendSession{..}  _ (Just SingleFrame{..}) = do+fdisplay :: FrontendSession    -- ^ frontend session data+         -> Bool+         -> Maybe SingleFrame  -- ^ the screen frame to draw+         -> IO ()+fdisplay _ _ Nothing = return ()+fdisplay FrontendSession{..}  _ (Just SingleFrame{..}) = do   -- let defaultStyle = C.defaultCursesStyle   -- Terminals with white background require this:   let defaultStyle = sstyles M.! Color.defAttr@@ -78,15 +77,16 @@   C.refresh  -- | Input key via the frontend.-nextEvent :: FrontendSession -> Maybe Bool -> IO K.KM-nextEvent _sess _ = keyTranslate `fmap` C.getKey C.refresh+nextEvent :: FrontendSession -> IO K.KM+nextEvent FrontendSession{sdebugCli=DebugModeCli{snoMore}} =+  if snoMore then return K.escKey+  else keyTranslate `fmap` C.getKey C.refresh  -- | Display a prompt, wait for any key.-promptGetAnyKey :: FrontendSession -> SingleFrame-             -> IO K.KM-promptGetAnyKey sess frame = do-  display sess True $ Just frame-  nextEvent sess Nothing+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess frame = do+  fdisplay sess True $ Just frame+  nextEvent sess  keyTranslate :: C.Key -> K.KM keyTranslate e = (\(key, modifier) -> K.KM {..}) $
Game/LambdaHack/Frontend/Gtk.hs view
@@ -4,7 +4,7 @@   ( -- * Session data type for the frontend     FrontendSession     -- * The output and input operations-  , display, promptGetAnyKey+  , fdisplay, fpromptGetKey     -- * Frontend administration tools   , frontendName, startup   ) where@@ -22,10 +22,9 @@ import Graphics.UI.Gtk hiding (Point) import System.Time -import Game.LambdaHack.Common.Animation (SingleFrame (..))+import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K (KM (..), Modifier (..),-                                                  keyTranslate)+import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.LQueue @@ -42,17 +41,18 @@   , stags       :: !(M.Map Color.Attr TextTag)  -- ^ text color tags for fg/bg   , schanKey    :: !(Chan K.KM)                 -- ^ channel for keyboard input   , sframeState :: !(MVar FrameState)-      -- ^ state of the frame finite machine; this mvar is locked+      -- ^ State of the frame finite machine. This mvar is locked       -- for a short time only, because it's needed, among others,       -- to display frames, which is done by a single polling thread,-      -- in real time+      -- in real time.   , slastFull   :: !(MVar (GtkFrame, Bool))-      -- ^ most recent full (not empty, not repeated) frame received-      -- and if any empty frame followed it; this mvar is locked+      -- ^ Most recent full (not empty, not repeated) frame received+      -- and if any empty frame followed it. This mvar is locked       -- for longer intervals to ensure that threads (possibly many)       -- add frames in an orderly manner, which is not done in real time,       -- though sometimes the frame display subsystem has to poll-      -- for a frame, in which case the locking interval becomes meaningful+      -- for a frame, in which case the locking interval becomes meaningful.+  , sdebugCli   :: !DebugModeCli  -- ^ client configuration   }  data GtkFrame = GtkFrame@@ -91,12 +91,12 @@ -- and need @sview@ and @stags@. Because of Windows, GTK needs to be -- on a bound thread, so we can't avoid the communication overhead -- of bound threads, so there's no point spawning a separate thread for GTK.-startup :: String -> (FrontendSession -> IO ()) -> IO ()+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO () startup = runGtk  -- | Sets up and starts the main GTK loop providing input and output.-runGtk :: String ->  (FrontendSession -> IO ()) -> IO ()-runGtk configFont k = do+runGtk :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+runGtk sdebugCli@DebugModeCli{sfont} cont = do   -- Init GUI.   unsafeInitGUIForThreadedRTS   -- Text attributes.@@ -125,7 +125,7 @@   let sess = FrontendSession{..}   -- Fork the game logic thread. When logic ends, game exits.   -- TODO: is postGUIAsync needed here?-  forkIO $ k sess >> postGUIAsync mainQuit+  forkIO $ cont sess >> postGUIAsync mainQuit   -- Fork the thread that periodically draws a frame from a queue, if any.   forkIO $ pollFrames sess Nothing   -- Fill the keyboard channel.@@ -151,7 +151,7 @@           writeChan schanKey K.KM {key, modifier}       return True   -- Set the font specified in config, if any.-  f <- fontDescriptionFromString configFont+  f <- fontDescriptionFromString $ fromMaybe "" sfont   widgetModifyFont sview (Just f)   -- Prepare font chooser dialog.   currentfont <- newIORef f@@ -186,8 +186,6 @@   containerAdd w sview   onDestroy w mainQuit   widgetShowAll w-  -- Wait until the other thread draws something and show the window.-  yield   mainGUI  -- | Output to the screen via the frontend.@@ -222,37 +220,38 @@             setIter a 1 as   setIter attr 1 attrs --- TODO: configure--- | Maximal frames per second.--- This is better low and fixed, to avoid jerkiness and delays--- that tell the player there are many intelligent enemies on the level.--- That's better than scaling AI sofistication down based on the FPS setting--- and machine speed.-maxFps :: Int-maxFps = 15- -- | Maximal polls per second.-maxPolls :: Int-maxPolls = let maxP = 120-           in assert (maxP >= 2 * maxFps `blame` (maxP, maxFps)) maxP+maxPolls :: Int -> Int+maxPolls maxFps = max 120 (2 * maxFps) +picoInMicro :: Int+picoInMicro = 1000000+ -- | Add a given number of microseconds to time. addTime :: ClockTime -> Int -> ClockTime-addTime (TOD s p) ms = TOD s (p + fromIntegral (ms * 1000000))+addTime (TOD s p) mus = TOD s (p + fromIntegral (mus * picoInMicro))  -- | The difference between the first and the second time, in microseconds. diffTime :: ClockTime -> ClockTime -> Int diffTime (TOD s1 p1) (TOD s2 p2) =-  fromIntegral (s1 - s2) * 1000000 +-  fromIntegral (p1 - p2) `div` 1000000+  fromIntegral (s1 - s2) * picoInMicro ++  fromIntegral (p1 - p2) `div` picoInMicro +microInSec :: Int+microInSec = 1000000++defaultMaxFps :: Int+defaultMaxFps = 15+ -- | Poll the frame queue often and draw frames at fixed intervals. pollFrames :: FrontendSession -> Maybe ClockTime -> IO ()-pollFrames sess (Just setTime) = do+pollFrames sess@FrontendSession{sdebugCli=DebugModeCli{smaxFps}}+           (Just setTime) = do   -- Check if the time is up.+  let maxFps = fromMaybe defaultMaxFps smaxFps   curTime <- getClockTime   let diffT = diffTime setTime curTime-  if diffT > 1000000 `div` maxPolls+  if diffT > microInSec `div` maxPolls maxFps     then do       -- Delay half of the time difference.       threadDelay $ diffTime curTime setTime `div` 2@@ -260,8 +259,10 @@     else       -- Don't delay, because time is up!       pollFrames sess Nothing-pollFrames sess@FrontendSession{sframeState} Nothing = do+pollFrames sess@FrontendSession{sframeState, sdebugCli=DebugModeCli{..}}+           Nothing = do   -- Time is up, check if we actually wait for anyting.+  let maxFps = fromMaybe defaultMaxFps smaxFps   fs <- takeMVar sframeState   case fs of     FPushed{..} ->@@ -269,23 +270,30 @@         Just (Just frame, queue) -> do           -- The frame has arrived so send it for drawing and update delay.           putMVar sframeState FPushed{fpushed = queue, fshown = frame}-          postGUIAsync $ output sess frame+          -- Count the time spent outputting towards the total frame time.           curTime <- getClockTime-          threadDelay $ 1000000 `div` (maxFps * 2)-          pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps+          -- Wait until the frame is drawn.+          postGUISync $ output sess frame+          -- Regardless of how much time drawing took, wait at least+          -- half of the normal delay time. This can distort the large-scale+          -- frame rhythm, but makes sure this frame can at all be seen.+          -- If the main GTK thread doesn't lag, large-scale rhythm will be OK.+          -- TODO: anyway, it's GC that causes visible snags, most probably.+          threadDelay $ microInSec `div` (maxFps * 2)+          pollFrames sess $ Just $ addTime curTime $ microInSec `div` maxFps         Just (Nothing, queue) -> do           -- Delay requested via an empty frame.           putMVar sframeState FPushed{fpushed = queue, ..}-          curTime <- getClockTime-          -- There is no problem if the delay is a bit delayed.-          threadDelay $ 1000000 `div` maxFps-          pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps+          unless snoDelay $+            -- There is no problem if the delay is a bit delayed.+            threadDelay $ microInSec `div` maxFps+          pollFrames sess Nothing         Nothing -> do           -- The queue is empty, the game logic thread lags.           putMVar sframeState fs           -- Time is up, the game thread is going to send a frame,           -- (otherwise it would change the state), so poll often.-          threadDelay $ 1000000 `div` maxPolls+          threadDelay $ microInSec `div` maxPolls maxFps           pollFrames sess Nothing     _ -> do       putMVar sframeState fs@@ -293,7 +301,7 @@       -- The slow polling also gives the game logic a head start       -- in creating frames in case one of the further frames is slow       -- to generate and would normally cause a jerky delay in drawing.-      threadDelay $ 1000000 `div` (maxFps * 2)+      threadDelay $ microInSec `div` (maxFps * 2)       pollFrames sess Nothing  -- | Add a game screen frame to the frame drawing channel, or show@@ -322,6 +330,7 @@     FNone | immediate -> do       -- If the frame not repeated, draw it.       maybe skip (postGUIAsync . output sess) nextFrame+      -- Frame sent, we may now safely release the queue lock.       putMVar sframeState FNone     FNone ->       -- Never start playing with an empty frame.@@ -371,23 +380,60 @@   putMVar sframeState FNone  -- | Add a frame to be drawn.-display :: FrontendSession -> Bool -> Maybe SingleFrame -> IO ()-display sess noDelay = pushFrame sess noDelay False+fdisplay :: FrontendSession    -- ^ frontend session data+         -> Bool+         -> Maybe SingleFrame  -- ^ the screen frame to draw+         -> IO ()+fdisplay sess noDelay = pushFrame sess noDelay False +-- Display all queued frames, synchronously.+displayAllFramesSync :: FrontendSession -> FrameState -> IO ()+displayAllFramesSync sess@FrontendSession{sdebugCli=DebugModeCli{..}} fs = do+  let maxFps = fromMaybe defaultMaxFps smaxFps+  case fs of+    FPushed{..} ->+      case tryReadLQueue fpushed of+        Just (Just frame, queue) -> do+          -- Display synchronously.+          postGUISync $ output sess frame+          threadDelay $ microInSec `div` maxFps+          displayAllFramesSync sess FPushed{fpushed = queue, fshown = frame}+        Just (Nothing, queue) -> do+          -- Delay requested via an empty frame.+          unless snoDelay $+            threadDelay $ microInSec `div` maxFps+          displayAllFramesSync sess FPushed{fpushed = queue, ..}+        Nothing ->+          -- The queue is empty.+          return ()+    _ ->+      -- Not in Push state to start with.+      return ()+ -- | Display a prompt, wait for any key.--- Starts in Push or None mode, stop in None mode.-promptGetAnyKey :: FrontendSession -> SingleFrame -> IO K.KM-promptGetAnyKey sess@FrontendSession{schanKey} frame = do+-- Starts in Push mode, ends in None mode.+-- Syncs with the drawing threads by showing the last or all queued frames.+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess@FrontendSession{sdebugCli=DebugModeCli{snoMore}, ..}+              frame = do   pushFrame sess True True $ Just frame-  km <- readChan schanKey-  trimFrameState sess-  return km+  if snoMore then do+    -- Show all frames synchronously.+    fs <- takeMVar sframeState+    displayAllFramesSync sess fs+    putMVar sframeState FNone+    return K.escKey+  else do+    km <- readChan schanKey+    -- Show the last frame and empty the queue.+    trimFrameState sess+    return km  -- | Tells a dead key. deadKey :: String -> Bool deadKey x = case x of-  "Shift_R"          -> True   "Shift_L"          -> True+  "Shift_R"          -> True   "Control_L"        -> True   "Control_R"        -> True   "Super_L"          -> True
Game/LambdaHack/Frontend/Std.hs view
@@ -3,105 +3,75 @@   ( -- * Session data type for the frontend     FrontendSession     -- * The output and input operations-  , display, promptGetAnyKey+  , fdisplay, fpromptGetKey     -- * Frontend administration tools   , frontendName, startup   ) where  import qualified Data.ByteString.Char8 as BS+import Data.Char (chr, ord) import qualified Data.List as L import Data.Text.Encoding (encodeUtf8) import qualified System.IO as SIO -import Game.LambdaHack.Common.Animation (SingleFrame (..))+import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K (KM (..), Key (..),-                                                  Modifier (..))+import qualified Game.LambdaHack.Common.Key as K  -- | No session data needs to be maintained by this frontend.-type FrontendSession = ()+data FrontendSession = FrontendSession+  { sdebugCli :: !DebugModeCli  -- ^ client configuration+  }  -- | The name of the frontend. frontendName :: String frontendName = "std"  -- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = k ()+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+startup sdebugCli k = k FrontendSession{..}  -- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data-        -> Bool-        -> Maybe SingleFrame  -- ^ the screen frame to draw-        -> IO ()-display _ _ Nothing = return ()-display _ _ (Just SingleFrame{..}) =+fdisplay :: FrontendSession    -- ^ frontend session data+         -> Bool+         -> Maybe SingleFrame  -- ^ the screen frame to draw+         -> IO ()+fdisplay _ _ Nothing = return ()+fdisplay _ _ (Just SingleFrame{..}) =   let chars = L.map (BS.pack . L.map Color.acChar) sfLevel       bs = [encodeUtf8 sfTop, BS.empty] ++ chars ++ [encodeUtf8 sfBottom, BS.empty]   in mapM_ BS.putStrLn bs  -- | Input key via the frontend.-nextEvent :: FrontendSession -> Maybe Bool -> IO K.KM-nextEvent sess mb = do-  e <- BS.hGet SIO.stdin 1-  let c = BS.head e-  if c == '\n'  -- let \n mark the end of input, for human players-    then nextEvent sess mb-    else return K.KM {key = keyTranslate c, modifier = K.NoModifier}+nextEvent :: FrontendSession -> IO K.KM+nextEvent FrontendSession{sdebugCli=DebugModeCli{snoMore}} =+  if snoMore then return K.escKey+  else do+    l <- BS.hGetLine SIO.stdin+    let c = case BS.uncons l of+          Nothing -> '\n'  -- empty line counts as RET+          Just (hd, _) -> hd+    return $! keyTranslate c  -- | Display a prompt, wait for any key.-promptGetAnyKey :: FrontendSession -> SingleFrame-             -> IO K.KM-promptGetAnyKey sess frame = do-  display sess True $ Just frame-  nextEvent sess Nothing+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess frame = do+  fdisplay sess True $ Just frame+  nextEvent sess --- HACK: Special translation that block commands the bots should not use--- and multiplies some other commands.-keyTranslate :: Char -> K.Key-keyTranslate e =+keyTranslate :: Char -> K.KM+keyTranslate e = (\(key, modifier) -> K.KM {..}) $   case e of-    -- Translate some special keys (use vi keys to move).-    '\ESC' -> K.Esc-    '\n'   -> K.Return-    '\r'   -> K.Return-    '\t'   -> K.Tab-    --  For bots: disable purely UI commands.-    'P'    -> K.Char 'U'-    'V'    -> K.Char 'Y'-    'O'    -> K.Char 'J'-    'I'    -> K.Char 'L'-    'R'    -> K.Char 'K'-    '?'    -> K.Char 'N'-    -- For bots: don't let them give up, write files, procrastinate.-    'Q'    -> K.Char 'H'-    'X'    -> K.Char 'B'-    'D'    -> K.Return-    '.'    -> K.Return-    -- For bots (assuming they go from '0' to 'z'): major commands.-    '<'    -> K.Char 'q'  -- ban ascending to speed up descending-    '>'    -> K.Char '>'-    'c'    -> K.Char 'c'-    'd'    -> K.Char 'r'  -- don't let bots drop stuff-    'g'    -> K.Char 'g'-    'i'    -> K.Char 'i'-    'o'    -> K.Char 'o'-    'q'    -> K.Char 'q'-    'r'    -> K.Char 'r'-    't'    -> K.Char 'g'  -- tagetting is too hard, so don't throw-    'z'    -> K.Char 'g'  -- and don't zap-    'p'    -> K.Char 'g'  -- and don't project-    'a'    -> K.Esc       -- and don't apply-    -- For bots: minor commands. Targeting is too hard, so don't do it.-    '*'    -> K.Char 'c'-    '/'    -> K.Char 'c'-    '['    -> K.Char 'g'-    ']'    -> K.Char 'g'-    '{'    -> K.Char 'g'-    '}'    -> K.Char 'g'-    -- Hack for bots: dump config at the start.-    ' '    -> K.Char 'D'-    -- Movement and hero selection.-    c | c `elem` "kjhlyubnKJHLYUBN" -> K.Char c-    c | c `elem` ['0'..'9'] -> K.Char c-    _      -> K.Char '>'  -- try hard to descend+    '\ESC' -> (K.Esc,     K.NoModifier)+    '\n'   -> (K.Return,  K.NoModifier)+    '\r'   -> (K.Return,  K.NoModifier)+    ' '    -> (K.Space,   K.NoModifier)+    '\t'   -> (K.Tab,     K.NoModifier)+    c | ord '\^A' <= ord c && ord c <= ord '\^Z' ->+        -- Alas, only lower-case letters.+        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)+        -- Movement keys are more important than hero selection,+        -- so disabling the latter and interpreting the keypad numbers+        -- as movement:+      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)+      | otherwise           -> (K.Char c,            K.NoModifier)
Game/LambdaHack/Frontend/Vty.hs view
@@ -3,7 +3,7 @@   ( -- * Session data type for the frontend     FrontendSession     -- * The output and input operations-  , display, promptGetAnyKey+  , fdisplay, fpromptGetKey     -- * Frontend administration tools   , frontendName, startup   ) where@@ -13,33 +13,35 @@ import Graphics.Vty import qualified Graphics.Vty as Vty -import Game.LambdaHack.Common.Animation (SingleFrame (..))+import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K (KM (..), Key (..),-                                                  Modifier (..))+import qualified Game.LambdaHack.Common.Key as K  -- | Session data maintained by the frontend.-type FrontendSession = Vty+data FrontendSession = FrontendSession+  { svty      :: !Vty  -- internal vty session+  , sdebugCli :: !DebugModeCli  -- ^ client configuration+      -- ^ Configuration of the frontend session.+  }  -- | The name of the frontend. frontendName :: String frontendName = "vty"  -- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = do-  fs <- mkVty-  k fs-  Vty.shutdown fs+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+startup sdebugCli k = do+  svty <- mkVty+  k FrontendSession{..}+  Vty.shutdown svty  -- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data--        -> Bool-        -> Maybe SingleFrame  -- ^ the screen frame to draw-        -> IO ()-display _ _ Nothing = return ()-display vty _ (Just SingleFrame{..}) =+fdisplay :: FrontendSession    -- ^ frontend session data+         -> Bool+         -> Maybe SingleFrame  -- ^ the screen frame to draw+         -> IO ()+fdisplay _ _ Nothing = return ()+fdisplay FrontendSession{svty} _ (Just SingleFrame{..}) =   let img = (foldr (<->) empty_image              . L.map (foldr (<|>) empty_image                       . L.map (\ Color.AttrChar{..} ->@@ -49,25 +51,26 @@               utf8_bytestring (setAttr Color.defAttr) (encodeUtf8 sfTop)               <-> img <->               utf8_bytestring (setAttr Color.defAttr) (encodeUtf8 sfBottom)-  in update vty pic+  in update svty pic  -- | Input key via the frontend.-nextEvent :: FrontendSession -> Maybe Bool -> IO K.KM-nextEvent sess mb = do-  e <- next_event sess-  case e of-    EvKey n mods -> do-      let key = keyTranslate n-          modifier = modifierTranslate mods-      return K.KM {key, modifier}-    _ -> nextEvent sess mb+nextEvent :: FrontendSession -> IO K.KM+nextEvent sess@FrontendSession{svty, sdebugCli=DebugModeCli{snoMore}} =+  if snoMore then return K.escKey+  else do+    e <- next_event svty+    case e of+      EvKey n mods -> do+        let key = keyTranslate n+            modifier = modifierTranslate mods+        return K.KM {key, modifier}+      _ -> nextEvent sess  -- | Display a prompt, wait for any key.-promptGetAnyKey :: FrontendSession -> SingleFrame-             -> IO K.KM-promptGetAnyKey sess frame = do-  display sess True $ Just frame-  nextEvent sess Nothing+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess frame = do+  fdisplay sess True $ Just frame+  nextEvent sess  keyTranslate :: Key -> K.Key keyTranslate n =
Game/LambdaHack/Server.hs view
@@ -5,9 +5,13 @@   ( mainSer   ) where +import Control.Concurrent+import qualified Control.Exception as Ex hiding (handle)+import qualified Data.Text as T import System.Environment (getArgs)  import Game.LambdaHack.Common.Action+import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.ClientCmd import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Kind as Kind@@ -18,38 +22,55 @@ import Game.LambdaHack.Server.LoopAction import Game.LambdaHack.Server.ServerSem import Game.LambdaHack.Server.State+import Game.LambdaHack.Utils.Thread  -- | The semantics of server commands. The resulting boolean value -- indicates if the command took some time. cmdSerSem :: (MonadAtomic m, MonadServer m) => CmdSer -> m Bool cmdSerSem cmd = case cmd of-  MoveSer aid dir -> moveSer aid dir False-  ExploreSer aid dir -> moveSer aid dir True-  RunSer aid dir -> runSer aid dir-  WaitSer aid -> waitSer aid >> return True-  PickupSer aid i k l -> pickupSer aid i k l >> return True-  DropSer aid iid -> dropSer aid iid >> return True-  ProjectSer aid p eps iid container -> projectSer aid p eps iid container-  ApplySer aid iid container -> applySer aid iid container >> return True-  TriggerSer aid p -> triggerSer aid p-  SetPathSer aid path -> setPathSer aid path >> return True+  TakeTimeSer cmd2 -> cmdSerSemTakeTime cmd2 >> return True   GameRestartSer aid t -> gameRestartSer aid t >> return False   GameExitSer aid -> gameExitSer aid >> return False   GameSaveSer _ -> gameSaveSer >> return False   CfgDumpSer aid -> cfgDumpSer aid >> return False +cmdSerSemTakeTime :: (MonadAtomic m, MonadServer m) => CmdSerTakeTime -> m ()+cmdSerSemTakeTime cmd = case cmd of+  MoveSer source target -> moveSer source target+  MeleeSer source target -> meleeSer source target+  DisplaceSer source target -> displaceSer source target+  AlterSer source tpos mfeat -> alterSer source tpos mfeat+  WaitSer aid -> waitSer aid+  PickupSer aid i k l -> pickupSer aid i k l+  DropSer aid iid -> dropSer aid iid+  ProjectSer aid p eps iid container -> projectSer aid p eps iid container+  ApplySer aid iid container -> applySer aid iid container+  TriggerSer aid mfeat -> triggerSer aid mfeat+  SetPathSer aid path -> setPathSer aid path+ debugArgs :: IO DebugModeSer debugArgs = do   args <- getArgs   let usage =-        [ "Configure server debug options here, gameplay in config.rules.ini."+        [ "Configure debug options here, gameplay options in config.rules.ini."         , "  --knowMap reveal map for all clients in the next game"         , "  --knowEvents show all events in the next game (needs --knowMap)"         , "  --sniffIn display all incoming commands on console "         , "  --sniffOut display all outgoing commands on console "         , "  --allClear let all map tiles be translucent"-        , "  --debugCli let clients emit their debug messages"-        , "  --tryFov m set a Field of View mode, where m can be"+        , "  --gameMode m start next game in the given mode"+        , "  --newGame start a new game, overwriting the save file"+        , "  --stopAfter n exit this game session after around n seconds"+        , "  --dbgMsgSer let the server emit its internal debug messages"+        , "  --font fn use the given font for the main game window"+        , "  --maxFps n display at most n frames per second"+        , "  --noDelay don't maintain any requested delays between frames"+        , "  --noMore auto-answer all prompts"+        , "  --noAnim don't show any animations"+        , "  --savePrefix prepend the text to all savefile names"+        , "  --frontendStd use the simple stdout/stdin frontend"+        , "  --dbgMsgCli let clients emit their internal debug messages"+        , "  --fovMode m set a Field of View mode, where m can be"         , "    Digital r, r > 0"         , "    Permissive"         , "    Shadow"@@ -66,12 +87,48 @@         (parseArgs rest) {sniffOut = True}       parseArgs ("--allClear" : rest) =         (parseArgs rest) {sallClear = True}-      parseArgs ("--tryFov" : "Digital" : r : rest) | (read r :: Int) > 0 =-        (parseArgs rest) {stryFov = Just $ Digital $ read r}-      parseArgs ("--tryFov" : mode : rest) =-        (parseArgs rest) {stryFov = Just $ read mode}-      parseArgs ("--debugCli" : rest) =-        (parseArgs rest) {sdebugCli = True}+      parseArgs ("--gameMode" : s : rest) =+        (parseArgs rest) {sgameMode = T.pack s}+      parseArgs ("--newGame" : rest) =+        let debugSer = parseArgs rest+        in debugSer { snewGameSer = True+                    , sdebugCli =+                         (sdebugCli debugSer) {snewGameCli = True}}+      parseArgs ("--stopAfter" : s : rest) =+        (parseArgs rest) {sstopAfter = Just $ read s}+      parseArgs ("--fovMode" : "Digital" : r : rest) | (read r :: Int) > 0 =+        (parseArgs rest) {sfovMode = Just $ Digital $ read r}+      parseArgs ("--fovMode" : mode : rest) =+        (parseArgs rest) {sfovMode = Just $ read mode}+      parseArgs ("--dbgMsgSer" : rest) =+        (parseArgs rest) {sdbgMsgSer = True}+      parseArgs ("--font" : s : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfont = Just s}}+      parseArgs ("--maxFps" : n : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli =+                       (sdebugCli debugSer) {smaxFps = Just $ read n}}+      parseArgs ("--noDelay" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {snoDelay = True}}+      parseArgs ("--noMore" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {snoMore = True}}+      parseArgs ("--noAnim" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {snoAnim = Just True}}+      parseArgs ("--savePrefix" : s : rest) =+        let debugSer = parseArgs rest+        in debugSer { ssavePrefixSer = Just s+                    , sdebugCli =+                         (sdebugCli debugSer) {ssavePrefixCli = Just s}}+      parseArgs ("--frontendStd" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendStd = True}}+      parseArgs ("--dbgMsgCli" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}}       parseArgs _ = error $ unlines usage   return $! parseArgs args @@ -84,17 +141,26 @@ mainSer :: (MonadAtomic m, MonadConnServer m)         => Kind.COps         -> (m () -> IO ())-        -> (Kind.COps-            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())-                -> (FactionId -> ChanServer CmdClientAI -> IO ())+        -> (Kind.COps -> DebugModeCli+            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer+                 -> IO ())+                -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime+                    -> IO ())                 -> IO ())             -> IO ())         -> IO ()-mainSer copsSlow exeSer exeFront = do+mainSer !copsSlow  -- evaluate fully to discover errors ASAP and free memory+        exeSer exeFront = do   sdebugNxt <- debugArgs   let cops = speedupCOps False copsSlow       loopServer = loopSer sdebugNxt cmdSerSem       exeServer executorUI executorAI = do-        exeSer (loopServer executorUI executorAI cops)-        waitForChildren-  exeFront cops exeServer+        -- Wait for clients to exit even in case of server crash+        -- (or server and client crash), which gives them time to save.+        -- TODO: send them a message to tell users "server crashed"+        -- and then let them exit.+        Ex.finally+          (exeSer (loopServer executorUI executorAI cops))+          (threadDelay 1000000)  -- server crash, show the error eventually+        waitForChildren childrenServer  -- no crash, wait indefinitely+  exeFront cops (sdebugCli sdebugNxt) exeServer
Game/LambdaHack/Server/Action.hs view
@@ -4,31 +4,36 @@ -- details. module Game.LambdaHack.Server.Action   ( -- * Action monads-    MonadServer( getServer, getsServer, putServer, modifyServer )+    MonadServer( getServer, getsServer, putServer, modifyServer, saveServer )   , MonadConnServer-  , tryRestore, updateConn, killAllClients, waitForChildren, speedupCOps+  , tryRestore, updateConn, killAllClients, speedupCOps     -- * Communication-  , sendUpdateUI, sendQueryUI, sendUpdateAI, sendQueryAI+  , sendUpdateAI, sendQueryAI, sendPingAI+  , sendUpdateUI, sendQueryUI, sendPingUI     -- * Assorted primitives-  , saveGameSer, saveGameBkp, dumpCfg+  , debugPrint, dumpCfg   , mkConfigRules, restoreScore, revealItems, deduceQuits-  , rndToAction, fovMode, resetFidPerception, getPerFid+  , rndToAction, resetSessionStart, elapsedSessionTimeGT+  , resetFidPerception, getPerFid+  , childrenServer   ) where  import Control.Concurrent-import Control.Concurrent.STM (TQueue, atomically, newTQueueIO)+import Control.Concurrent.STM (TQueue, atomically) import qualified Control.Concurrent.STM as STM-import Control.Exception (finally) import Control.Monad import qualified Control.Monad.State as St import qualified Data.EnumMap.Strict as EM import Data.Key (mapWithKeyM, mapWithKeyM_) import Data.List import Data.Maybe+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T+import Game.LambdaHack.Utils.Thread import System.Directory-import System.IO (stderr)+import System.FilePath+import System.IO import System.IO.Unsafe (unsafePerformIO) import qualified System.Random as R import System.Time@@ -43,28 +48,29 @@ import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Random+import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Frontend as Frontend import Game.LambdaHack.Server.Action.ActionClass import qualified Game.LambdaHack.Server.Action.ConfigIO as ConfigIO-import qualified Game.LambdaHack.Server.Action.Save as Save import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.File -fovMode :: MonadServer m => m FovMode-fovMode = do-  configFovMode <- getsServer (configFovMode . sconfig)-  sdebugSer <- getsServer sdebugSer-  return $ fromMaybe configFovMode $ stryFov sdebugSer+debugPrint :: MonadServer m => Text -> m ()+debugPrint t = do+  debug <- getsServer $ sdbgMsgSer . sdebugSer+  when debug $ liftIO $ do+    T.hPutStrLn stderr t+    hFlush stderr  -- | Update the cached perception for the selected level, for a faction. -- The assumption is the level, and only the level, has changed since@@ -72,37 +78,22 @@ resetFidPerception :: MonadServer m => FactionId -> LevelId -> m () resetFidPerception fid lid = do   cops <- getsState scops-  lvl <- getsLevel lid id-  configFov <- fovMode+  lvl <- getLevel lid+  fovMode <- getsServer $ sfovMode . sdebugSer   s <- getState-  let per = levelPerception cops s configFov fid lid lvl+  let per = levelPerception cops s (fromMaybe (Digital 12) fovMode) fid lid lvl       upd = EM.adjust (EM.adjust (const per) lid) fid   modifyServer $ \ser -> ser {sper = upd (sper ser)}  getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception getPerFid fid lid = do   pers <- getsServer sper-  let fper = fromMaybe (assert `failure` (lid, fid)) $ EM.lookup fid pers-      per = fromMaybe (assert `failure` (lid, fid)) $ EM.lookup lid fper+  let fper = fromMaybe (assert `failure` "no perception for faction"+                               `with` (lid, fid)) $ EM.lookup fid pers+      per = fromMaybe (assert `failure` "no perception for level"+                              `with` (lid, fid)) $ EM.lookup lid fper   return $! per -saveGameSer :: MonadServer m => m ()-saveGameSer = do-  s <- getState-  ser <- getServer-  config <- getsServer sconfig-  liftIO $ Save.saveGameSer config s ser---- | Save a backup of the save game file, in case of crashes.------ See 'Save.saveGameBkp'.-saveGameBkp :: MonadServer m => m ()-saveGameBkp = do-  s <- getState-  ser <- getServer-  config <- getsServer sconfig-  liftIO $ Save.saveGameBkpSer config s ser- -- | Dumps the current game rules configuration to a file. dumpCfg :: MonadServer m => FilePath -> m () dumpCfg fn = do@@ -125,13 +116,23 @@     liftIO $ T.hPutStrLn stderr d   liftIO $ atomically $ STM.writeTQueue fromServer cmd -readTQueue :: MonadConnServer m => TQueue CmdSer -> m CmdSer-readTQueue toServer = do+readTQueueAI :: MonadConnServer m => TQueue CmdSerTakeTime -> m CmdSerTakeTime+readTQueueAI toServer = do   cmd <- liftIO $ atomically $ STM.readTQueue toServer   debug <- getsServer $ sniffIn . sdebugSer   when debug $ do+    let aid = aidCmdSerTakeTime cmd+    d <- debugAid aid "CmdSerTakeTime" cmd+    liftIO $ T.hPutStrLn stderr d+  return cmd++readTQueueUI :: MonadConnServer m => TQueue CmdSer -> m CmdSer+readTQueueUI toServer = do+  cmd <- liftIO $ atomically $ STM.readTQueue toServer+  debug <- getsServer $ sniffIn . sdebugSer+  when debug $ do     let aid = aidCmdSer cmd-    d <- debugAid aid (showT ("CmdSer", cmd))+    d <- debugAid aid "CmdSer" cmd     liftIO $ T.hPutStrLn stderr d   return cmd @@ -140,23 +141,50 @@   conn <- getsDict $ snd . (EM.! fid)   writeTQueueAI cmd $ fromServer conn -sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdSer+sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdSerTakeTime sendQueryAI fid aid = do   conn <- getsDict $ snd . (EM.! fid)   writeTQueueAI (CmdQueryAI aid) $ fromServer conn-  readTQueue $ toServer conn+  readTQueueAI $ toServer conn +sendPingAI :: MonadConnServer m => FactionId -> m ()+sendPingAI fid = do+  conn <- getsDict $ snd . (EM.! fid)+  writeTQueueAI CmdPingAI $ fromServer conn+  -- debugPrint $ "AI client" <+> showT fid <+> "pinged..."+  cmdHack <- readTQueueAI $ toServer conn+  -- debugPrint $ "AI client" <+> showT fid <+> "responded."+  assert (cmdHack == WaitSer (toEnum (-1))) skip+ sendUpdateUI :: MonadConnServer m => FactionId -> CmdClientUI -> m () sendUpdateUI fid cmd = do-  conn <- getsDict $ snd . fst . (EM.! fid)-  writeTQueueUI cmd $ fromServer conn+  cs <- getsDict $ fst . (EM.! fid)+  case cs of+    Nothing -> assert `failure` "no channel for faction" `with` fid+    Just (_, conn) ->+      writeTQueueUI cmd $ fromServer conn  sendQueryUI :: MonadConnServer m => FactionId -> ActorId -> m CmdSer sendQueryUI fid aid = do-  conn <- getsDict $ snd . fst . (EM.! fid)-  writeTQueueUI (CmdQueryUI aid) $ fromServer conn-  readTQueue $ toServer conn+  cs <- getsDict $ fst . (EM.! fid)+  case cs of+    Nothing -> assert `failure` "no channel for faction" `with` fid+    Just (_, conn) -> do+      writeTQueueUI (CmdQueryUI aid) $ fromServer conn+      readTQueueUI $ toServer conn +sendPingUI :: MonadConnServer m => FactionId -> m ()+sendPingUI fid = do+  cs <- getsDict $ fst . (EM.! fid)+  case cs of+    Nothing -> assert `failure` "no channel for faction" `with` fid+    Just (_, conn) -> do+      writeTQueueUI CmdPingUI $ fromServer conn+      -- debugPrint $ "UI client" <+> showT fid <+> "pinged..."+      cmdHack <- readTQueueUI $ toServer conn+      -- debugPrint $ "UI client" <+> showT fid <+> "responded."+      assert (cmdHack == TakeTimeSer (WaitSer (toEnum (-1)))) skip+ -- | Create a server config file. Warning: when it's used, the game state -- may still be undefined, hence the content ops are given as an argument. mkConfigRules :: MonadServer m@@ -168,8 +196,8 @@ -- may still be undefined, hence the config is given as an argument. restoreScore :: MonadServer m => Config -> m HighScore.ScoreTable restoreScore Config{configScoresFile} = do-  b <- liftIO $ doesFileExist configScoresFile-  if not b+  configExists <- liftIO $ doesFileExist configScoresFile+  if not configExists     then return HighScore.empty     else liftIO $ strictDecodeEOF configScoresFile @@ -179,7 +207,7 @@   assert (maybe True ((fid ==) . bfid) mbody) skip   factionD <- getsState sfactionD   let fact = factionD EM.! fid-  assert (isHumanFact fact) skip+  assert (playerHuman $ gplayer fact) skip   total <- case mbody of     Just body -> getsState $ snd . calculateTotal body     Nothing -> case gleader fact of@@ -197,6 +225,17 @@                            (ntable :: HighScore.ScoreTable)   maybe skip saveScore $ HighScore.register table total time status date +resetSessionStart :: MonadServer m => m ()+resetSessionStart = do+  sstart <- liftIO getClockTime+  modifyServer $ \ser -> ser {sstart}++elapsedSessionTimeGT :: MonadServer m => Int -> m Bool+elapsedSessionTimeGT stopAfter = do+  current <- liftIO getClockTime+  TOD s p <- getsServer sstart+  return $ TOD (s + fromIntegral stopAfter) p <= current+ revealItems :: (MonadAtomic m, MonadServer m)             => Maybe FactionId -> Maybe Actor -> m () revealItems mfid mbody = do@@ -225,18 +264,18 @@     Just Conquer -> return ()     Just Escape -> return ()     _ -> do-      when (isHumanFact fact) $ do+      when (playerUI $ gplayer fact) $ do         revealItems (Just fid) mbody+      when (playerHuman $ gplayer fact) $ do         registerScore status mbody fid       execCmdAtomic $ QuitFactionA fid mbody oldSt $ Just status       modifyServer $ \ser -> ser {squit = True}  -- end turn ASAP  -- Send any QuitFactionA actions that can be deduced from their current state. deduceQuits :: (MonadAtomic m, MonadServer m) => Actor -> Status -> m ()-deduceQuits body Status{stOutcome=Defeated} = assert `failure` body-deduceQuits body Status{stOutcome=Camping} = assert `failure` body-deduceQuits body Status{stOutcome=Restart} = assert `failure` body-deduceQuits body Status{stOutcome=Conquer} = assert `failure` body+deduceQuits body status@Status{stOutcome}+  | stOutcome `elem` [Defeated, Camping, Restart, Conquer] =+    assert `failure` "no quitting to deduce" `with` (status, body) deduceQuits body status = do   cops <- getsState scops   let fid = bfid body@@ -252,13 +291,13 @@       keysInGame = map fst assocsInGame       assocsSpawn = filter (isSpawnFact cops . snd) assocsInGame       assocsNotSummon = filter (not . isSummonFact cops . snd) assocsInGame-      assocsHuman = filter (isHumanFact . snd) assocsInGame+      assocsUI = filter (playerUI . gplayer . snd) assocsInGame   case assocsNotSummon of-    _ | null assocsHuman ->-      -- No screensaver mode for now --- all non-human players win.+    _ | null assocsUI ->+      -- All non-UI players left in the game win.       mapQuitF status{stOutcome=Conquer} keysInGame     [] ->-      -- Only summons remain so all win, human or not, allied or not.+      -- Only summons remain so all win, UI or human or not, allied or not.       mapQuitF status{stOutcome=Conquer} keysInGame     (_, fact1) : rest | null assocsSpawn && all (isAllied fact1 . fst) rest ->       -- Only one allied team remains in a no-spawners game.@@ -272,105 +311,105 @@     _ -> return ()  tryRestore :: MonadServer m-           => Kind.COps -> m (Maybe (State, StateServer))-tryRestore Kind.COps{corule} = do+           => Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer))+tryRestore Kind.COps{corule} sdebugSer = do   let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule+      prefix = ssavePrefixSer sdebugSer   -- A throw-away copy of rules config, to be used until the old   -- version of the config can be read from the savefile.-  (sconfig, _, _) <- mkConfigRules corule-  liftIO $ Save.restoreGameSer sconfig pathsDataFile+  (Config{ configAppDataDir+         , configRulesCfgFile+         , configScoresFile }, _, _) <- mkConfigRules corule+  let copies =+        [ (configRulesCfgFile <.> ".default", configRulesCfgFile <.> ".ini")+        , (configScoresFile, configScoresFile) ]+      name = fromMaybe "save" prefix <.> saveName+  liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile +-- Global variable for all children threads of the server.+childrenServer :: MVar [MVar ()]+{-# NOINLINE childrenServer #-}+childrenServer = unsafePerformIO (newMVar [])+ -- | Update connections to the new definition of factions. -- Connect to clients in old or newly spawned threads -- that read and write directly to the channels. updateConn :: (MonadAtomic m, MonadConnServer m)-           => (FactionId -> Frontend.ChanFrontend -> ChanServer CmdClientUI+           => (FactionId+               -> Frontend.ChanFrontend+               -> ChanServer CmdClientUI CmdSer                -> IO ())-           -> (FactionId -> ChanServer CmdClientAI -> IO ())+           -> (FactionId+               -> ChanServer CmdClientAI CmdSerTakeTime+               -> IO ())            -> m () updateConn executorUI executorAI = do   -- Prepare connections based on factions.   oldD <- getDict-  let mkChanServer :: IO (ChanServer c)+  let mkChanServer :: IO (ChanServer c d)       mkChanServer = do-        fromServer <- newTQueueIO-        toServer <- newTQueueIO+        fromServer <- STM.newTQueueIO+        toServer <- STM.newTQueueIO         return ChanServer{..}       mkChanFrontend :: IO Frontend.ChanFrontend-      mkChanFrontend = newTQueueIO-      addConn fid _ = case EM.lookup fid oldD of+      mkChanFrontend = STM.newTQueueIO+      addConn :: FactionId -> Faction -> IO ConnServerFaction+      addConn fid fact = case EM.lookup fid oldD of         Just conns -> return conns  -- share old conns and threads-        Nothing -> do+        Nothing | playerUI $ gplayer fact -> do           connF <- mkChanFrontend           connS <- mkChanServer           connAI <- mkChanServer-          return ((connF, connS), connAI)+          return (Just (connF, connS), connAI)+        Nothing -> do+          connAI <- mkChanServer+          return (Nothing, connAI)   factionD <- getsState sfactionD   d <- liftIO $ mapWithKeyM addConn factionD   let newD = d `EM.union` oldD  -- never kill old clients   putDict newD-  -- Spawn and kill client threads.+  -- Spawn client threads.   let toSpawn = newD EM.\\ oldD-      fdict fid = ( fst $ fst-                    $ fromMaybe (assert `failure` fid)+      fdict fid = ( fst+                    $ fromMaybe (assert `failure` "no channel" `with` fid)+                    $ fst+                    $ fromMaybe (assert `failure` "no faction" `with` fid)                     $ EM.lookup fid newD                   , maybe T.empty gname  -- a faction can go inactive                     $ EM.lookup fid factionD                   )       fromM = Frontend.fromMulti Frontend.connMulti   liftIO $ void $ takeMVar fromM  -- stop Frontend-  let forkUI fid (connF, connS) = void $ forkChild $ executorUI fid connF connS-      forkAI fid connS = void $ forkChild $ executorAI fid connS+  let forkUI fid (connF, connS) =+        void $ forkChild childrenServer $ executorUI fid connF connS+      forkAI fid connS =+        void $ forkChild childrenServer $ executorAI fid connS       forkClient fid (connUI, connAI) = do-        -- This is fragile: when a connection is reused, clients are not-        -- respawned, even if AI or UI usage changes (it does not, currently,-        -- thanks to faction numbering, etc.).-        -- TODO: perhaps spawn both AI and UI clients always, but then-        -- the UI client should not display a welcome message, until-        -- the server tells it to.-        when (isHumanFact $ factionD EM.! fid) $ forkUI fid connUI-        when (usesAIFact $ factionD EM.! fid) $ forkAI fid connAI+        -- When a connection is reused, clients are not respawned,+        -- even if UI usage changes, but it works OK thanks to UI faction+        -- clients distinguished by positive FactionId numbers.+        forkAI fid connAI  -- AI clients always needed, e.g., for auto-explore+        maybe skip (forkUI fid) connUI   liftIO $ mapWithKeyM_ forkClient toSpawn-  nH <- nHumans-  liftIO $ putMVar fromM (nH, fdict)  -- restart Frontend+  nU <- nUI+  liftIO $ putMVar fromM (nU, fdict)  -- restart Frontend  killAllClients :: (MonadAtomic m, MonadConnServer m) => m () killAllClients = do   d <- getDict   let sendKill fid _ = do-        sendUpdateUI fid $ CmdAtomicUI $ KillExitA fid+        -- We can't check in sfactionD, because client can be from an old game.+        when (fromEnum fid > 0) $+          sendUpdateUI fid $ CmdAtomicUI $ KillExitA fid         sendUpdateAI fid $ CmdAtomicAI $ KillExitA fid   mapWithKeyM_ sendKill d --- Swiped from http://www.haskell.org/ghc/docs/latest/html/libraries/base-4.6.0.0/Control-Concurrent.html-children :: MVar [MVar ()]-{-# NOINLINE children #-}-children = unsafePerformIO (newMVar [])--waitForChildren :: IO ()-waitForChildren = do-  cs <- takeMVar children-  case cs of-    [] -> return ()-    m : ms -> do-      putMVar children ms-      takeMVar m-      waitForChildren--forkChild :: IO () -> IO ThreadId-forkChild io = do-  mvar <- newEmptyMVar-  childs <- takeMVar children-  putMVar children (mvar : childs)-  forkIO (io `finally` putMVar mvar ())--- 7.6  forkFinally io (\_ -> putMVar mvar ())- -- | Compute and insert auxiliary optimized components into game content, -- to be used in time-critical sections of the code. speedupCOps :: Bool -> Kind.COps -> Kind.COps speedupCOps allClear copsSlow@Kind.COps{cotile=tile} =   let ospeedup = Tile.speedup allClear tile-      cotile = tile {Kind.ospeedup = ospeedup}+      cotile = tile {Kind.ospeedup = Just ospeedup}   in copsSlow {Kind.cotile = cotile}  -- | Invoke pseudo-random computation with the generator kept in the state.
Game/LambdaHack/Server/Action/ActionClass.hs view
@@ -15,9 +15,13 @@   -- We do not provide a MonadIO instance, so that outside of Action/   -- nobody can subvert the action monads by invoking arbitrary IO.   liftIO       :: IO a -> m a+  saveServer   :: m ()  class MonadServer m => MonadConnServer m where   getDict      :: m ConnServerDict   getsDict     :: (ConnServerDict -> a) -> m a   modifyDict   :: (ConnServerDict -> ConnServerDict) -> m ()   putDict      :: ConnServerDict -> m ()++saveName :: String+saveName = serverSaveName
Game/LambdaHack/Server/Action/ActionType.hs view
@@ -10,17 +10,23 @@ import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.State.Strict hiding (State) import qualified Data.EnumMap.Strict as EM+import Data.Maybe+import System.FilePath  import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.ClientCmd+import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Server.Action.ActionClass+import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.State  data SerState = SerState-  { serState  :: !State        -- ^ current global state-  , serServer :: !StateServer  -- ^ current server state-  , serDict   :: !ConnServerDict     -- ^ client-server connection information+  { serState  :: !State           -- ^ current global state+  , serServer :: !StateServer     -- ^ current server state+  , serDict   :: !ConnServerDict  -- ^ client-server connection information+  , serToSave :: !(Save.ChanSave (State, StateServer))+                                  -- ^ connection to the save thread   }  -- | Server state transformation monad.@@ -45,6 +51,11 @@   putServer    s =     ActionSer $ modify $ \serS -> serS {serServer = s}   liftIO         = ActionSer . IO.liftIO+  saveServer     = ActionSer $ do+    s <- gets serState+    ser <- gets serServer+    toSave <- gets serToSave+    IO.liftIO $ Save.saveToChan toSave (s, ser)  instance MonadConnServer ActionSer where   getDict      = ActionSer $ gets serDict@@ -56,8 +67,16 @@  -- | Run an action in the @IO@ monad, with undefined state. executorSer :: ActionSer () -> IO ()-executorSer m = evalStateT (runActionSer m)-                  SerState { serState = emptyState-                           , serServer = emptyStateServer-                           , serDict = EM.empty-                           }+executorSer m =+  let saveFile (_, ser) =+        configAppDataDir (sconfig ser)+        </> fromMaybe "save" (ssavePrefixSer (sdebugSer ser))+        <.> saveName+      exe toSave =+        evalStateT (runActionSer m)+          SerState { serState = emptyState+                   , serServer = emptyStateServer+                   , serDict = EM.empty+                   , serToSave = toSave+                   }+  in Save.wrapInSaves saveFile exe
Game/LambdaHack/Server/Action/ConfigIO.hs view
@@ -4,13 +4,10 @@   ( mkConfigRules, dump   ) where -import Control.Arrow (first, (***)) import Control.DeepSeq import qualified Data.Char as Char import qualified Data.ConfigFile as CF-import qualified Data.EnumMap.Strict as EM import Data.List-import qualified Data.Map.Strict as M import qualified Data.Text as T import System.Directory import System.Environment@@ -27,8 +24,8 @@  overrideCP :: CP -> FilePath -> IO CP overrideCP cp@(CP defCF) cfile = do-  b <- doesFileExist cfile-  if not b+  cpExists <- doesFileExist cfile+  if not cpExists     then return cp     else do       c <- CF.readfile defCF cfile@@ -37,11 +34,11 @@ -- | Read a player configuration file and use it to override -- options from a default config. Currently we can't unset options, -- only override. The default config, passed in argument @configDefault@,--- is expected to come from a default configuration file included via CPP.+-- is expected to come from a default configuration file included via TH. -- The player configuration comes from file @cfile@. mkConfig :: String -> FilePath -> IO CP mkConfig configDefault cfile = do-  let delComment = map (drop 2) $ init . drop 3 $ lines configDefault+  let delComment = map (drop 2) $ lines configDefault       unConfig = unlines delComment       -- Evaluate, to catch config errors ASAP.       !defCF = forceEither $ CF.readstring CF.emptyCP unConfig@@ -67,7 +64,7 @@ set :: CP -> CF.SectionSpec -> CF.OptionSpec -> String -> CP set (CP conf) s o v =   if CF.has_option conf s o-  then assert `failure`"Overwritten config option: " ++ s ++ "." ++ o+  then assert `failure`"overwritten config option" `with` (s, o)   else CP $ forceEither $ CF.set conf s o v  -- | Gets a random generator from the config or,@@ -98,11 +95,6 @@ toCP :: CF.ConfigParser -> CP toCP cf = CP $ cf {CF.optionxform = id} --- | In case of corruption, just fail.-forceEither :: Show a => Either a b -> b-forceEither (Left a)  = assert `failure` a-forceEither (Right b) = b- -- | A simplified access to an option in a given section, -- with simple error reporting (no internal errors are caught nor hidden). -- If there is no such option, gives Nothing.@@ -118,41 +110,32 @@ get (CP conf) s o =   if CF.has_option conf s o   then forceEither $ CF.get conf s o-  else assert `failure` "Unknown config option: " ++ s ++ "." ++ o+  else assert `failure` "unknown CF option" `with` (s, o, CF.to_string conf)  -- | An association list corresponding to a section. Fails if no such section. getItems :: CP -> CF.SectionSpec -> [(String, String)] getItems (CP conf) s =   if CF.has_section conf s   then forceEither $ CF.items conf s-  else assert `failure` "Unknown config section: " ++ s+  else assert `failure` "unknown CF section" `with` (s, CF.to_string conf)  parseConfigRules :: FilePath -> CP -> Config parseConfigRules dataDir cp =   let configSelfString = let CP conf = cp in CF.to_string conf-      configCaves =-        let section = getItems cp "caves"-            readCaves = EM.fromList . map (toEnum *** first T.pack)-        in M.fromList $ map (T.pack *** (readCaves . read)) section       configFirstDeathEnds = get cp "engine" "firstDeathEnds"       configFovMode = get cp "engine" "fovMode"       configSaveBkpClips = get cp "engine" "saveBkpClips"       configAppDataDir = dataDir       configScoresFile = dataDir </> get cp "file" "scoresFile"       configRulesCfgFile = dataDir </> "config.rules"+      configSavePrefix = get cp "file" "savePrefix"       configHeroNames =         let toNumber (ident, name) =               case stripPrefix "HeroName_" ident of                 Just n -> (read n, T.pack name)-                Nothing -> assert `failure` ("wrong hero name id " ++ ident)+                Nothing -> assert `failure` "wrong hero name id" `with` ident             section = getItems cp "heroName"         in map toNumber section-      configPlayers =-        let section = getItems cp "players"-        in M.fromList $ map (T.pack *** read) section-      configScenario =-        let section = getItems cp "scenario"-        in M.fromList $ map (T.pack *** read) section   in Config{..}  -- | Read and parse rules config file and supplement it with random seeds.
− Game/LambdaHack/Server/Action/Save.hs 
@@ -1,94 +0,0 @@--- | Saving and restoring server game state.-module Game.LambdaHack.Server.Action.Save-  ( saveGameBkpSer, saveGameSer, restoreGameSer-  ) where--import Control.Concurrent-import qualified Control.Exception as Ex hiding (handle)-import Control.Monad-import System.Directory-import System.FilePath-import System.IO-import System.IO.Unsafe (unsafePerformIO)--import Game.LambdaHack.Common.State-import Game.LambdaHack.Server.Config-import Game.LambdaHack.Server.State-import Game.LambdaHack.Utils.File---- TODO: Refactor the client and server Save.hs, after--- https://github.com/kosmikus/LambdaHack/issues/37.--saveLock :: MVar ()-{-# NOINLINE saveLock #-}-saveLock = unsafePerformIO newEmptyMVar---- | Save game to the backup savefile, in case of crashes.--- This is only a backup, so no problem is the game is shut down--- before saving finishes, so we don't wait on the mvar. However,--- if a previous save is already in progress, we skip this save.-saveGameBkpSer :: Config -> State -> StateServer -> IO ()-saveGameBkpSer Config{configAppDataDir} s ser = do-  b <- tryPutMVar saveLock ()-  when b $-    void $ forkIO $ do-      let saveFile = configAppDataDir </> "server.sav"-          saveFileBkp = saveFile <.> ".bkp"-      encodeEOF saveFile (s, ser)-      renameFile saveFile saveFileBkp-      takeMVar saveLock---- | Save a simple serialized version of the current state.--- Protected by a lock to avoid corrupting the file.-saveGameSer :: Config -> State -> StateServer -> IO ()-saveGameSer Config{configAppDataDir} s ser = do-  putMVar saveLock ()-  let saveFile = configAppDataDir </> "server.sav"-  encodeEOF saveFile (s, ser)-  takeMVar saveLock---- | Restore a saved game, if it exists. Initialize directory structure--- and cope over data files, if needed.-restoreGameSer :: Config -> (FilePath -> IO FilePath)-               -> IO (Maybe (State, StateServer))-restoreGameSer Config{ configAppDataDir-                     , configRulesCfgFile-                     , configScoresFile }-               pathsDataFile = do-  -- Create user data directory and copy files, if not already there.-  tryCreateDir configAppDataDir-  tryCopyDataFiles pathsDataFile-    [ (configRulesCfgFile <.> ".default", configRulesCfgFile <.> ".ini")-    , (configScoresFile, configScoresFile) ]-  let saveFile = configAppDataDir </> "server.sav"-      saveFileBkp = saveFile <.> ".bkp"-  sb <- doesFileExist saveFile-  bb <- doesFileExist saveFileBkp-  when sb $ renameFile saveFile saveFileBkp-  -- If the savefile exists but we get IO or decoding errors, we show them,-  -- back up the savefile, move it out of the way and start a new game.-  -- If the savefile was randomly corrupted or made read-only,-  -- that should solve the problem. Serious IO problems (e.g. failure-  -- to create a user data directory) terminate the program with an exception.-  res <- Ex.try $-    if sb-      then do-        (s, ser) <- strictDecodeEOF saveFileBkp-        return $ Just (s, ser)-      else-        if bb-          then do-            (s, ser) <- strictDecodeEOF saveFileBkp-            let msg = "No server savefile found. "-                      ++ "Restoring from a backup savefile."-            hPutStrLn stderr msg-            return $ Just (s, ser)-          else return Nothing-  let handler :: Ex.SomeException -> IO (Maybe (State, StateServer))-      handler e = do-        let msg = "Starting a new game, because server restore failed. "-                  ++ "The error message is: "-                  ++ (unwords . lines) (show e)-        hPutStrLn stderr msg-        return Nothing-  either handler return res
Game/LambdaHack/Server/AtomicSemSer.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Sending atomic commands to clients and executing them on the server. -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.@@ -23,6 +22,7 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.Action import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.Assert@@ -73,9 +73,8 @@   -- Send some actions to the clients, one faction at a time.   knowEvents <- getsServer $ sknowEvents . sdebugSer   let sendUI fid cmdUI =-        when (isHumanFact $ factionD EM.! fid) $ sendUpdateUI fid cmdUI-      sendAI fid cmdAI =-        when (usesAIFact $ factionD EM.! fid) $ sendUpdateAI fid cmdAI+        when (playerUI $ gplayer $ factionD EM.! fid) $ sendUpdateUI fid cmdUI+      sendAI fid cmdAI = sendUpdateAI fid cmdAI       sendA fid cmd = do         sendUI fid $ CmdAtomicUI cmd         sendAI fid $ CmdAtomicAI cmd@@ -134,7 +133,7 @@         PosFidAndSer fid2 -> when (fid == fid2) $ sendUpdate fid atomic         PosSer -> return ()         PosAll -> sendUpdate fid atomic-        PosNone -> assert `failure` (atomic, fid)+        PosNone -> assert `failure` "illegal sending" `with` (atomic, fid)   mapWithKeyM_ (\fid _ -> send fid) factionD  atomicRemember :: LevelId -> Perception -> State -> [CmdAtomic]@@ -159,7 +158,7 @@       inItem = concatMap fBag inFloor       -- Tiles.       cotile = Kind.cotile (scops s)-      inTileMap = map (\p -> (p, hideTile cotile p lvl)) inFov+      inTileMap = map (\p -> (p, hideTile cotile lvl p)) inFov       atomicTile = if null inTileMap then [] else [SpotTileA lid inTileMap]       -- TODO: somehow also use this       -- bonus = case strongestSearch itemAssocs of
Game/LambdaHack/Server/Config.hs view
@@ -1,23 +1,18 @@ -- | Personal game configuration file type definitions. module Game.LambdaHack.Server.Config-  ( Config(..), Caves, Players(..), Player(..), Scenario(..)+  ( Config(..)   ) where  import Control.DeepSeq import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.Map.Strict (Map) import Data.Text (Text) -import Game.LambdaHack.Common.Level import Game.LambdaHack.Server.Fov  -- | Fully typed contents of the rules config file. This config -- is a part of the game server. data Config = Config   { configSelfString     :: !String-    -- caves-  , configCaves          :: !(Map Text Caves)     -- engine   , configFirstDeathEnds :: !Bool   , configFovMode        :: !FovMode@@ -26,105 +21,33 @@   , configAppDataDir     :: !FilePath   , configScoresFile     :: !FilePath   , configRulesCfgFile   :: !FilePath+  , configSavePrefix     :: !String     -- heroNames   , configHeroNames      :: ![(Int, Text)]-    -- players-  , configPlayers        :: !(Map Text Players)-    -- scenario-  , configScenario       :: !(Map Text Scenario)   }   deriving Show -type Caves = EM.EnumMap LevelId (Text, Bool)--data Players = Players-  { playersHuman    :: [Player]-  , playersComputer :: [Player]-  , playersEnemy    :: [(Text, Text)]-  , playersAlly     :: [(Text, Text)]-  }-  deriving (Show, Read)--data Player = Player-  { playerName    :: Text-  , playerKind    :: Text-  , playerInitial :: Int-  , playerEntry   :: LevelId-  }-  deriving (Show, Read)--instance NFData Player--instance Binary Player where-  put Player{..} = do-    put playerName-    put playerKind-    put playerInitial-    put playerEntry-  get = do-    playerName <- get-    playerKind <- get-    playerInitial <- get-    playerEntry <- get-    return Player{..}--instance NFData Players--instance Binary Players where-  put Players{..} = do-    put playersHuman-    put playersComputer-    put playersEnemy-    put playersAlly-  get = do-    playersHuman <- get-    playersComputer <- get-    playersEnemy <- get-    playersAlly <- get-    return Players{..}--data Scenario = Scenario-  { scenarioPlayers :: Text-  , scenarioDungeon :: Text-  }-  deriving (Show, Read)--instance NFData Scenario--instance Binary Scenario where-  put Scenario{..} = do-    put scenarioPlayers-    put scenarioDungeon-  get = do-    scenarioPlayers <- get-    scenarioDungeon <- get-    return Scenario{..}- instance NFData Config  instance Binary Config where   put Config{..} = do     put configSelfString-    put configCaves     put configFirstDeathEnds     put configFovMode     put configSaveBkpClips     put configAppDataDir     put configScoresFile     put configRulesCfgFile+    put configSavePrefix     put configHeroNames-    put configPlayers-    put configScenario   get = do     configSelfString     <- get-    configCaves          <- get     configFirstDeathEnds <- get     configFovMode        <- get     configSaveBkpClips <- get     configAppDataDir     <- get     configScoresFile     <- get     configRulesCfgFile   <- get+    configSavePrefix <- get     configHeroNames      <- get-    configPlayers        <- get-    configScenario       <- get     return Config{..}
Game/LambdaHack/Server/DungeonGen.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | The main dungeon generation routine. module Game.LambdaHack.Server.DungeonGen   ( FreshDungeon(..), dungeonGen@@ -6,11 +5,9 @@  import Control.Arrow (first) import Control.Monad-import qualified Control.Monad.State as St import qualified Data.EnumMap.Strict as EM import Data.List import Data.Maybe-import qualified System.Random as R  import qualified Game.LambdaHack.Common.Effect as Effect import qualified Game.LambdaHack.Common.Feature as F@@ -22,8 +19,8 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.CaveKind+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.DungeonGen.Cave hiding (TileMapXY) import Game.LambdaHack.Server.DungeonGen.Place import Game.LambdaHack.Utils.Assert@@ -36,75 +33,135 @@   pickedTiles <- replicateM (cxsize * cysize) cdefTile   return $ Kind.listArray bounds pickedTiles Kind.// assocs -placeStairs :: Kind.Ops TileKind -> TileMap -> CaveKind -> [Place]-            -> Rnd ( Point, Kind.Id TileKind-                   , Point, Kind.Id TileKind-                   , Point, Kind.Id TileKind )-placeStairs cotile@Kind.Ops{opick} cmap CaveKind{..} dplaces = do-  su <- findPos cmap (const (Tile.hasFeature cotile F.CanActor))-  sd <- findPosTry 1000 cmap-          [ \ l _ -> chessDist cxsize su l >= cminStairDist-          , \ l _ -> chessDist cxsize su l >= cminStairDist `div` 2-          , \ l t -> l /= su && Tile.hasFeature cotile F.CanActor t-          ]-  sq <- findPos cmap (const (Tile.hasFeature cotile F.CanActor))-  let fitArea pos = inside cxsize pos . qarea-      findLegend pos =-        maybe clitLegendTile qlegend $ find (fitArea pos) dplaces-  upEscape <--    opick (findLegend su) $ Tile.kindHasFeature $ F.Cause Effect.Escape-  upId   <- opick (findLegend su) $ Tile.kindHasFeature F.Ascendable-  downId <- opick (findLegend sd) $ Tile.kindHasFeature F.Descendable-  return (sq, upEscape, su, upId, sd, downId)+placeStairs :: Kind.Ops TileKind -> TileMap -> CaveKind -> [Point]+            -> Rnd Point+placeStairs cotile cmap CaveKind{..} ps = do+  let dist cmin l _ = all (\pos -> chessDist cxsize l pos > cmin) ps+  findPosTry 1000 cmap+    [ dist $ cminStairDist+    , dist $ cminStairDist `div` 2+    , dist $ cminStairDist `div` 4+    , dist $ cminStairDist `div` 8+    , \p t -> Tile.hasFeature cotile F.CanActor t+              && dist 0 p t  -- can't overwrite stairs with other stairs+    ]  -- | Create a level from a cave, from a cave kind.-buildLevel :: Kind.COps -> Cave -> Int -> Int -> Int -> Bool -> Rnd Level-buildLevel Kind.COps{ cotile=cotile@Kind.Ops{opick}-                    , cocave=Kind.Ops{okind} }-           Cave{..} ldepth minD maxD escapeFeature = do-  let kc@CaveKind{..} = okind dkind+buildLevel :: Kind.COps -> Cave -> Int -> Int -> Int -> Int -> Maybe Bool+           -> Rnd Level+buildLevel cops@Kind.COps{ cotile=cotile@Kind.Ops{opick, okind}+                         , cocave=Kind.Ops{okind=cokind} }+           Cave{..} ldepth minD maxD nstairUp escapeFeature = do+  let kc@CaveKind{..} = cokind dkind+      fitArea pos = inside cxsize pos . qarea+      findLegend pos = maybe clitLegendTile qlegend+                       $ find (fitArea pos) dplaces+      hasEscapeAndSymbol sym t = Tile.kindHasFeature (F.Cause Effect.Escape) t+                                 && tsymbol t == sym+      ascendable  = Tile.kindHasFeature $ F.Cause (Effect.Ascend 1)+      descendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend (-1))   cmap <- convertTileMaps (opick cdefTile (const True)) cxsize cysize dmap-  (sq, upEscape, su, upId, sd, downId) <- placeStairs cotile cmap kc dplaces-  litemNum <- rollDice citemNum-  secret <- random-  let stairs = (if ldepth == minD then [] else [(su, upId)])-               ++ (if ldepth == maxD then [] else [(sd, downId)])-               ++ (if not escapeFeature then [] else [(sq, upEscape)])-      ltile = cmap Kind.// stairs-      f !n !tk | Tile.isExplorable cotile tk = n + 1-               | otherwise = n-      lclear = Kind.foldlArray f 0 ltile-  -- TODO: split this into Level.defaultLevel-      level = Level-        { ldepth-        , lprio = EM.empty-        , lfloor = EM.empty-        , ltile-        , lxsize = cxsize-        , lysize = cysize-        , lsmell = EM.empty-        , ldesc = cname-        , lstair = (su, sd)-        , lseen = 0-        , lclear-        , ltime = timeTurn-        , litemNum-        , lsecret = secret-        , lhidden = chidden-        }-  return level+  -- We keep two-way stairs separately, in the last component.+  let makeStairs :: Bool -> Bool -> Bool+                 -> ( [(Point, Kind.Id TileKind)]+                    , [(Point, Kind.Id TileKind)]+                    , [(Point, Kind.Id TileKind)] )+                 -> Rnd ( [(Point, Kind.Id TileKind)]+                        , [(Point, Kind.Id TileKind)]+                        , [(Point, Kind.Id TileKind)] )+      makeStairs moveUp noAsc noDesc (up, down, upDown) =+        if (if moveUp then noAsc else noDesc) then+          return (up, down, upDown)+        else do+          let cond tk = (if moveUp then ascendable tk else descendable tk)+                        && (if noAsc then not (ascendable tk) else True)+                        && (if noDesc then not (descendable tk) else True)+              stairsCur = up ++ down ++ upDown+              posCur = nub $ sort $ map fst stairsCur+          spos <- placeStairs cotile cmap kc posCur+          stairId <- opick (findLegend spos) cond+          let st = (spos, stairId)+              asc = ascendable $ okind stairId+              desc = descendable $ okind stairId+          return $ case (asc, desc) of+                     (True, False) -> (st : up, down, upDown)+                     (False, True) -> (up, st : down, upDown)+                     (True, True)  -> (up, down, st : upDown)+                     (False, False) -> assert `failure` st+  (stairsUp1, stairsDown1, stairsUpDown1) <-+    makeStairs False (ldepth == maxD) (ldepth == minD) ([], [], [])+  assert (null stairsUp1) skip+  let nstairUpLeft = nstairUp - length stairsUpDown1+  (stairsUp2, stairsDown2, stairsUpDown2) <-+    foldM (\sts _ -> makeStairs True (ldepth == maxD) (ldepth == minD) sts)+          (stairsUp1, stairsDown1, stairsUpDown1)+          [1 .. nstairUpLeft]+  -- If only a single tile of up-and-down stairs, add one more stairs down.+  (stairsUp, stairsDown, stairsUpDown) <-+    if length (stairsUp2 ++ stairsDown2) == 0+    then (makeStairs False True (ldepth == minD)+             (stairsUp2, stairsDown2, stairsUpDown2))+    else return (stairsUp2, stairsDown2, stairsUpDown2)+  let stairsUpAndUpDown = stairsUp ++ stairsUpDown+  assert (length stairsUpAndUpDown == nstairUp) skip+  let stairsTotal = stairsUpAndUpDown ++ stairsDown+      posTotal = nub $ sort $ map fst stairsTotal+  epos <- placeStairs cotile cmap kc posTotal+  escape <- case escapeFeature of+              Nothing -> return []+              Just True -> do+                upEscape <- opick (findLegend epos) $ hasEscapeAndSymbol '<'+                return [(epos, upEscape)]+              Just False -> do+                downEscape <- opick (findLegend epos) $ hasEscapeAndSymbol '>'+                return [(epos, downEscape)]+  let exits = stairsTotal ++ escape+      ltile = cmap Kind.// exits+      -- We reverse the order in down stairs, to minimize long stair chains.+      lstair = ( map fst $ stairsUp ++ stairsUpDown+               , map fst $ stairsUpDown ++ stairsDown )+  -- traceShow (ldepth, nstairUp, (stairsUp, stairsDown, stairsUpDown)) skip+  litemNum <- castDice citemNum+  lsecret <- random+  return $! levelFromCaveKind cops kc ldepth ltile lstair litemNum lsecret -findGenerator :: Kind.COps -> Caves -> LevelId -> LevelId -> LevelId+levelFromCaveKind :: Kind.COps+                  -> CaveKind -> Int -> TileMap -> ([Point], [Point])+                  -> Int -> Int+                  -> Level+levelFromCaveKind Kind.COps{cotile}+                  CaveKind{..} ldepth ltile lstair litemNum lsecret =+  Level+    { ldepth+    , lprio = EM.empty+    , lfloor = EM.empty+    , ltile+    , lxsize = cxsize+    , lysize = cysize+    , lsmell = EM.empty+    , ldesc = cname+    , lstair+    , lseen = 0+    , lclear = let f !n !tk | Tile.isExplorable cotile tk = n + 1+                            | otherwise = n+               in Kind.foldlArray f 0 ltile+    , ltime = timeTurn+    , litemNum+    , lsecret+    , lhidden = chidden+    }++findGenerator :: Kind.COps -> Caves+              -> LevelId -> LevelId -> LevelId -> Int -> Int               -> Rnd Level-findGenerator cops caves ldepth minD maxD = do+findGenerator cops caves ldepth minD maxD totalDepth nstairUp = do   let Kind.COps{cocave=Kind.Ops{opick}} = cops       (genName, escapeFeature) =-        fromMaybe ("dng", False) $ EM.lookup ldepth caves+        fromMaybe ("dng", Nothing) $ EM.lookup ldepth caves   ci <- opick genName (const True)-  let maxDepth = if minD == maxD then 10 else fromEnum maxD-  cave <- buildCave cops (fromEnum ldepth) maxDepth ci+  cave <- buildCave cops (fromEnum ldepth) totalDepth ci   buildLevel cops cave-             (fromEnum ldepth) (fromEnum minD) (fromEnum maxD)+             (fromEnum ldepth) (fromEnum minD) (fromEnum maxD) nstairUp              escapeFeature  -- | Freshly generated and not yet populated dungeon.@@ -119,17 +176,19 @@   let (minD, maxD) =         case (EM.minViewWithKey caves, EM.maxViewWithKey caves) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` caves-  assert (minD <= maxD && fromEnum minD >= 1 `blame` caves) skip-  let gen :: R.StdGen -> LevelId -> (R.StdGen, (LevelId, Level))-      gen g ldepth =-        let (g1, g2) = R.split g-            findG = findGenerator cops caves ldepth minD maxD-            res = St.evalState findG g1-        in (g2, (ldepth, res))-      con :: R.StdGen -> (FreshDungeon, R.StdGen)-      con g = let (gd, levels) = mapAccumL gen g [minD..maxD]-                  freshDungeon = EM.fromList levels-                  freshDepth = if minD == maxD then 10 else fromEnum maxD-              in (FreshDungeon{..}, gd)-  St.state con+          _ -> assert `failure` "no caves" `with` caves+      totalDepth = if minD == maxD+                   then 10+                   else fromEnum maxD - fromEnum minD + 1+  let gen :: (Int, [(LevelId, Level)]) -> LevelId+          -> Rnd (Int, [(LevelId, Level)])+      gen (nstairUp, l) ldepth = do+        lvl <- findGenerator cops caves ldepth minD maxD totalDepth nstairUp+        -- nstairUp for the next level is nstairDown for the current level+        let nstairDown = length $ snd $ lstair lvl+        return $ (nstairDown, (ldepth, lvl) : l)+  (nstairUpLast, levels) <- foldM gen (0, []) $ reverse [minD..maxD]+  assert (nstairUpLast == 0) skip+  let freshDungeon = EM.fromList levels+      freshDepth = totalDepth+  return FreshDungeon{..}
Game/LambdaHack/Server/DungeonGen/AreaRnd.hs view
@@ -82,7 +82,8 @@ -- | Pick a single random connection between adjacent areas within a grid. randomConnection :: (X, Y) -> Rnd (PointXY, PointXY) randomConnection (nx, ny) =-  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do+  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` "wrong connection"+                                               `with` (nx, ny)) $ do   rb <- oneOf [False, True]   if rb || ny <= 1     then do
Game/LambdaHack/Server/DungeonGen/Cave.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Generation of caves (not yet inhabited dungeon levels) from cave kinds. module Game.LambdaHack.Server.DungeonGen.Cave   ( TileMapXY, ItemFloorXY, Cave(..), buildCave@@ -34,9 +33,9 @@ -- | The type of caves (not yet inhabited dungeon levels). data Cave = Cave   { dkind   :: !(Kind.Id CaveKind)  -- ^ the kind of the cave-  , dmap    :: TileMapXY            -- ^ tile kinds in the cave-  , ditem   :: ItemFloorXY          -- ^ starting items in the cave-  , dplaces :: [Place]              -- ^ places generated in the cave+  , dmap    :: !TileMapXY           -- ^ tile kinds in the cave+  , ditem   :: !ItemFloorXY         -- ^ starting items in the cave+  , dplaces :: ![Place]             -- ^ places generated in the cave   }   deriving Show @@ -74,8 +73,8 @@                         , cocave=Kind.Ops{okind} }           ln depth ci = do   let kc@CaveKind{..} = okind ci-  lgrid@(gx, gy) <- rollDiceXY cgrid-  lminplace <- rollDiceXY cminPlaceSize+  lgrid@(gx, gy) <- castDiceXY cgrid+  lminplace <- castDiceXY cminPlaceSize   let gs = grid lgrid (0, 0, cxsize - 1, cysize - 1)   mandatory1 <- replicateM (cnonVoidMin `div` 2) $                   xyInArea (0, 0, gx `div` 3, gy - 1)@@ -109,26 +108,26 @@         return (EM.union tmap m, place : pls)   (lplaces, dplaces) <- foldM addPl (fence, []) places0   let lcorridors = EM.unions (L.map (digCorridors pickedCorTile) cs)-  let lm = EM.unionWith (mergeCorridor cotile) lcorridors lplaces+      lm = EM.unionWith (mergeCorridor cotile) lcorridors lplaces   -- Convert wall openings into doors, possibly.-  dmap <--    let f l (p, t) =-          if not $ Tile.hasFeature cotile F.Suspect t-          then return l  -- no opening to start with+  let f l (p, t) =+        if not $ Tile.hasFeature cotile F.Suspect t+        then return l  -- no opening to start with+        else do+          -- Openings have a certain chance to be doors+          -- and doors have a certain chance to be open.+          rd <- chance cdoorChance+          if not rd then+            return $ EM.insert p pickedCorTile l  -- opening kept           else do-            -- Openings have a certain chance to be doors-            -- and doors have a certain chance to be open.-            rd <- chance cdoorChance-            if not rd-              then return $ EM.insert p pickedCorTile l  -- opening kept-              else do-                doorClosedId <- Tile.changeTo cotile t  -- hack 47-                doorOpenId   <- Tile.changeTo cotile doorClosedId-                ro <- chance copenChance-                if not ro-                  then return $ EM.insert p doorClosedId l-                  else return $ EM.insert p doorOpenId l-    in foldM f lm (EM.assocs lm)+            ro <- chance copenChance+            doorClosedId <- Tile.revealAs cotile t+            if not ro then+              return $ EM.insert p doorClosedId l+            else do+              doorOpenId <- Tile.openTo cotile doorClosedId+              return $ EM.insert p doorOpenId l+  dmap <- foldM f lm (EM.assocs lm)   let cave = Cave         { dkind = ci         , ditem = EM.empty@@ -147,4 +146,4 @@  mergeCorridor :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind               -> Kind.Id TileKind-mergeCorridor cotile _ = Tile.hiddenAs cotile+mergeCorridor cotile _ = Tile.hideAs cotile
Game/LambdaHack/Server/DungeonGen/Place.hs view
@@ -100,7 +100,7 @@            = assert (not (trivialArea r) `blame` r) $ do   qsolidFence <- opick cfillerTile (const True)   dark <- chanceDeep ln depth cdarkChance-  qkind <- popick (T.pack "rogue") (placeValid r)+  qkind <- popick "rogue" (placeValid r)   let kr = pokind qkind       qlegend = if dark then cdarkLegendTile else clitLegendTile       qseen = False@@ -167,13 +167,13 @@       interior = case pcover of         CAlternate ->           let tile :: Int -> [a] -> [a]-              tile _ []  = assert `failure` pl+              tile _ []  = assert `failure` "nothing to tile" `with` pl               tile d pat =                 L.take d (L.cycle $ L.init pat ++ L.init (L.reverse pat))           in fillInterior tile         CStretch ->           let stretch :: Int -> [a] -> [a]-              stretch _ []  = assert `failure` pl+              stretch _ []  = assert `failure` "nothing to streth" `with` pl               stretch d pat = tileReflect d (pat ++ L.repeat (L.last pat))           in fillInterior stretch         CReflect ->
Game/LambdaHack/Server/EffectSem.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Effect semantics. -- TODO: document module Game.LambdaHack.Server.EffectSem@@ -36,6 +35,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.Action import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.State@@ -71,7 +71,7 @@           => Effect.Effect Int -> ActorId -> ActorId           -> m Bool effectSem effect source target = case effect of-  Effect.NoEffect -> effectNoEffect+  Effect.NoEffect -> effectNoEffect target   Effect.Heal p -> effectHeal p target   Effect.Hurt nDm p -> effectWound nDm p source target   Effect.Mindprobe _ -> effectMindprobe target@@ -84,15 +84,16 @@   Effect.Regeneration p -> effectSem (Effect.Heal p) source target   Effect.Searching p -> effectSearching p source   Effect.Ascend p -> effectAscend p target-  Effect.Descend p -> effectDescend p target   Effect.Escape -> effectEscape target  -- + Individual semantic functions for effects  -- ** NoEffect -effectNoEffect :: Monad m => m Bool-effectNoEffect = return False+effectNoEffect :: MonadAtomic m => ActorId -> m Bool+effectNoEffect target = do+  execSfxAtomic $ EffectD target Effect.NoEffect+  return False  -- ** Heal @@ -118,10 +119,12 @@             => RollDice -> Int -> ActorId -> ActorId             -> m Bool effectWound nDm power source target = do-  n <- rndToAction $ rollDice nDm+  n <- rndToAction $ castDice nDm   let deltaHP = - (n + power)   if deltaHP >= 0-    then return False+    then do+      execSfxAtomic $ EffectD target Effect.NoEffect+      return False     else do       -- Damage the target.       execCmdAtomic $ HealActorA target deltaHP@@ -153,13 +156,14 @@ effectDominate :: (MonadAtomic m, MonadServer m)                => ActorId -> ActorId -> m Bool effectDominate source target = do-  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops   sb <- getsState (getActorBody source)   tb <- getsState (getActorBody target)   if bfid tb == bfid sb then do     execSfxAtomic $ EffectD target Effect.NoEffect     return False   else do+    -- Announce domination before the actor changes sides.+    execSfxAtomic $ EffectD target Effect.Dominate     -- TODO: Perhaps insert a turn of delay here to allow countermeasures.     electLeader (bfid tb) (blid tb) target     ais <- getsState $ getActorItem target@@ -168,7 +172,7 @@     execCmdAtomic $ CreateActorA target bNew ais     leaderOld <- getsState $ gleader . (EM.! bfid sb) . sfactionD     -- Halve the speed as a side-effect of domination.-    let speed = fromMaybe (aspeed $ okind $ bkind bNew) $ bspeed bNew+    let speed = bspeed bNew         delta = speedScale (1%2) speed     when (delta > speedZero) $       execCmdAtomic $ HasteActorA target (speedNegate delta)@@ -204,7 +208,8 @@ effectCallFriend :: (MonadAtomic m, MonadServer m)                    => Int -> ActorId -> ActorId                    -> m Bool-effectCallFriend power source target = do+effectCallFriend power source target = assert (power > 0) $ do+  -- Obvious effect, nothing announced.   Kind.COps{cotile} <- getsState scops   sm <- getsState (getActorBody source)   tm <- getsState (getActorBody target)@@ -231,10 +236,13 @@  addActor :: (MonadAtomic m, MonadServer m)          => Kind.Id ActorKind -> FactionId -> Point -> LevelId -> Int-         -> Maybe Char -> Maybe Text -> Maybe Color.Color -> Time+         -> Char -> Text -> Color.Color -> Time          -> m ActorId addActor mk bfid pos lid hp bsymbol bname bcolor time = do-  let m = actorTemplate mk bsymbol bname bcolor Nothing hp Nothing pos lid time+  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops+  let kind = okind mk+      speed = aspeed kind+      m = actorTemplate mk bsymbol bname bcolor speed hp Nothing pos lid time                         bfid False   acounter <- getsServer sacounter   modifyServer $ \ser -> ser {sacounter = succ acounter}@@ -248,25 +256,26 @@         -> m ActorId addHero bfid ppos lid configHeroNames mNumber time = do   Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops-  Faction{gcolor, gconfig} <- getsState $ (EM.! bfid) . sfactionD+  Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD   let kId = heroKindId coactor-  hp <- rndToAction $ rollDice $ ahp $ okind kId+  hp <- rndToAction $ castDice $ ahp $ okind kId   mhs <- mapM (\n -> getsState $ \s -> tryFindHeroK s bfid n) [0..9]   let freeHeroK = elemIndex Nothing mhs       n = fromMaybe (fromMaybe 100 freeHeroK) mNumber       symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n       name | gcolor == Color.BrWhite =         fromMaybe ("Hero" <+> showT n) $ lookup n configHeroNames-           | otherwise = gconfig <+> "Hero" <+> showT n+           | otherwise = playerName gplayer <+> "Hero" <+> showT n       startHP = hp - (hp `div` 5) * min 3 n   addActor-    kId bfid ppos lid startHP (Just symbol) (Just name) (Just gcolor) time+    kId bfid ppos lid startHP symbol name gcolor time  -- ** SpawnMonster  effectSummon :: (MonadAtomic m, MonadServer m)              => Int -> ActorId -> m Bool-effectSummon power target = do+effectSummon power target = assert (power > 0) $ do+  -- Obvious effect, nothing announced.   Kind.COps{cotile} <- getsState scops   tm <- getsState (getActorBody target)   ps <- getsState $ nearbyFreePoints cotile (const True) (bpos tm) (blid tm)@@ -307,14 +316,16 @@            -> m ActorId addMonster mk bfid ppos lid time = do   Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-  hp <- rndToAction $ rollDice $ ahp $ okind mk-  addActor mk bfid ppos lid hp Nothing Nothing Nothing time+  let kind = okind mk+  hp <- rndToAction $ castDice $ ahp kind+  addActor mk bfid ppos lid hp (asymbol kind) (aname kind) (acolor kind) time  -- ** CreateItem  effectCreateItem :: (MonadAtomic m, MonadServer m)                  => Int -> ActorId -> m Bool-effectCreateItem power target = do+effectCreateItem power target = assert (power > 0) $ do+  -- Obvious effect, nothing announced.   tm <- getsState $ getActorBody target   void $ createItems power (bpos tm) (blid tm)   return True@@ -325,7 +336,7 @@   Kind.COps{coitem} <- getsState scops   flavour <- getsServer sflavour   discoRev <- getsServer sdiscoRev-  ldepth <- getsLevel lid ldepth+  Level{ldepth} <- getLevel lid   depth <- getsState sdepth   replicateM_ n $ do     (item, k, _) <- rndToAction $ newItem coitem flavour discoRev ldepth depth@@ -352,10 +363,10 @@     return False   else do     tm <- getsState $ getActorBody target-    oldSmell <- getsLevel (blid tm) lsmell+    Level{lsmell} <- getLevel $ blid tm     let f p fromSm =           execCmdAtomic $ AlterSmellA (blid tm) p (Just fromSm) Nothing-    mapWithKeyM_ f oldSmell+    mapWithKeyM_ f lsmell     execSfxAtomic $ EffectD target Effect.ApplyPerfume     return True @@ -363,6 +374,7 @@  -- ** Searching +-- TODO or to remove. effectSearching :: MonadAtomic m => Int -> ActorId -> m Bool effectSearching power source = do   execSfxAtomic $ EffectD source $ Effect.Searching power@@ -378,80 +390,92 @@  effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m Bool effLvlGoUp aid k = do-  Kind.COps{coactor} <- getsState scops-  bOld <- getsState $ getActorBody aid-  let lidOld = blid bOld-      posOld = bpos bOld-  whereto <- getsState $ \s -> whereTo s lidOld k-  case whereto of-    Nothing -> -- We are at the "end" of the dungeon.-      -- TODO: perhaps return Maybe Text explaining why it failed, instead?-      return False-    Just (lidNew, posNew) -> do-      -- The actor is added to the new level, but there can be other actors-      -- at his new position.-      inhabitants <- getsState $ posToActor posNew lidNew-      case inhabitants of-        Nothing -> return ()-        Just aid2 -> do-          -- Start switching places. Move the inhabitant to where the actor is.-          switchLevels aid2 lidOld posOld-          -- Alert about the switch.-          b2 <- getsState $ getActorBody aid2-          let part2 = partActor coactor b2-              verb = "be pushed to another level"-              msg2 = makeSentence [MU.SubjectVerbSg part2 verb]-          execSfxAtomic $ MsgFidD (bfid b2) msg2-          -- There are now two actors at @posOld@.-      switchLevels aid lidNew posNew-      -- The property of at most one actor on a tile is restored.-      void $ getsState $ posToActor posOld lidOld  -- assertion is inside-      return True+  b1 <- getsState $ getActorBody aid+  ais1 <- getsState $ getActorItem aid+  let lid1 = blid b1+      pos1 = bpos b1+  (lid2, pos2) <- getsState $ whereTo lid1 pos1 k+  if lid2 == lid1 && pos2 == pos1 then return False+  else do+    -- The actor is added to the new level, but there can be other actors+    -- at his new position.+    inhabitants <- getsState $ posToActor pos2 lid2+    case inhabitants of+      Nothing ->+        -- Move the actor out of the way.+        switchLevels1 aid+      Just aid2 -> do+        b2 <- getsState $ getActorBody aid2+        ais2 <- getsState $ getActorItem aid2+        -- Alert about the switch.+        let part2 = partActor b2+            verb = "be pushed to another level"+            msg2 = makeSentence [MU.SubjectVerbSg part2 verb]+        execSfxAtomic $ MsgFidD (bfid b2) msg2+        -- Move the actor out of the way.+        switchLevels1 aid+        -- Move the inhabitant out of the way.+        switchLevels1 aid2+        -- Move the inhabitant to where the actor was.+        switchLevels2 aid2 b2 ais2 lid1 pos1+    -- Move the actor to where the inhabitant was, if any.+    switchLevels2 aid b1 ais1 lid2 pos2+    -- Verify only one actor on every tile.+    !_ <- getsState $ posToActor pos1 lid1  -- assertion is inside+    !_ <- getsState $ posToActor pos2 lid2  -- assertion is inside+    return True -switchLevels :: MonadAtomic m => ActorId -> LevelId -> Point -> m ()-switchLevels aid lidNew posNew = do+switchLevels1 :: MonadAtomic m => ActorId -> m ()+switchLevels1 aid = do   bOld <- getsState $ getActorBody aid   ais <- getsState $ getActorItem aid+  let side = bfid bOld+  mleader <- getsState $ gleader . (EM.! side) . sfactionD+  -- Prevent leader pointing to a non-existing actor.+  when (isJust mleader) $  -- trouble, if the actors are of the same faction+    execCmdAtomic $ LeadFactionA side mleader Nothing+  -- Remove the actor from the old level.+  -- Onlookers see somebody disappear suddenly.+  -- @DestroyActorA@ is too loud, so use @LoseActorA@ instead.+  execCmdAtomic $ LoseActorA aid bOld ais++switchLevels2 :: MonadAtomic m+              => ActorId -> Actor -> [(ItemId, Item)] -> LevelId -> Point+              -> m ()+switchLevels2 aid bOld ais lidNew posNew = do   let lidOld = blid bOld       side = bfid bOld-  assert (lidNew /= lidOld `blame` (lidNew, "stairs looped" :: Text)) skip+  assert (lidNew /= lidOld `blame` "stairs looped" `with` lidNew) skip   -- Sync the actor time with the level time.   timeOld <- getsState $ getLocalTime lidOld   timeLastVisited <- getsState $ getLocalTime lidNew+  -- This time calculation may cause a double move of a foe of the same+  -- speed, but this is OK --- the foe didn't have a chance to move+  -- before, because the arena went inactive, so he moves now one more time.   let delta = timeAdd (btime bOld) (timeNegate timeOld)       bNew = bOld { blid = lidNew                   , btime = timeAdd timeLastVisited delta+                  , bwait = timeZero  -- no longer braced                   , bpos = posNew-                  , boldpos = posNew}  -- new level, new direction-  -- Prevent leader pointing to a non-existing actor.+                  , boldpos = posNew  -- new level, new direction+                  , bpath = Nothing }   mleader <- getsState $ gleader . (EM.! side) . sfactionD-  execCmdAtomic $ LeadFactionA side mleader Nothing-  -- Remove the actor from the old level.-  -- Onlookers see somebody disappear suddenly.-  -- @DestroyActorA@ is too loud, so use @LoseActorA@ instead.-  execCmdAtomic $ LoseActorA aid bOld ais-  -- but this will be fixed just below.+  -- Materialize the actor at the new location.   -- Onlookers see somebody appear suddenly. The actor himself   -- sees new surroundings and has to reset his perception.   execCmdAtomic $ CreateActorA aid bNew ais-  -- Inhabitants of the new location not checked, so there may be-  -- two actors at the same position at this point. Beware.   -- Changing levels is so important, that the leader changes.-  execCmdAtomic $ LeadFactionA side Nothing (Just aid)---- ** Descend--effectDescend :: MonadAtomic m => Int -> ActorId -> m Bool-effectDescend power target = do-  b <- effLvlGoUp target (-power)-  when b $ execSfxAtomic $ EffectD target $ Effect.Descend power-  return b+  -- This also helps the actor clear the staircase and so avoid+  -- being pushed back to the level he came from by another actor.+  when (isNothing mleader) $  -- trouble, if the actors are of the same faction+    execCmdAtomic $ LeadFactionA side Nothing (Just aid)  -- ** Escape  -- | The faction leaves the dungeon. effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool effectEscape aid = do+  -- Obvious effect, nothing announced.   b <- getsState $ getActorBody aid   let fid = bfid b   spawn <- getsState $ isSpawnFaction fid
Game/LambdaHack/Server/Fov.hs view
@@ -158,10 +158,10 @@ -- when other similar modifiers are added. -- | Field Of View scanning mode. data FovMode =-    Shadow       -- ^ restrictive shadow casting-  | Permissive   -- ^ permissive FOV-  | Digital Int  -- ^ digital FOV with the given radius-  | Blind        -- ^ only feeling out adjacent tiles by touch+    Shadow        -- ^ restrictive shadow casting+  | Permissive    -- ^ permissive FOV+  | Digital !Int  -- ^ digital FOV with the given radius+  | Blind         -- ^ only feeling out adjacent tiles by touch   deriving (Show, Read)  instance Binary FovMode where
Game/LambdaHack/Server/Fov/Digital.hs view
@@ -121,7 +121,7 @@       (n2, k2) = intersect (p2, f) 0   in n1 * k2 >= k1 * n2 --- | Debug: check is a view border line for DFOV is legal.+-- | Debug: check if a view border line for DFOV is legal. debugLine :: Line -> (Bool, String) debugLine line@(B(x1, y1), B(x2, y2))   | not (allB (>= 0) [y1, y2]) =
Game/LambdaHack/Server/LoopAction.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | The main loop of the server, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Server.LoopAction (loopSer) where@@ -7,10 +6,12 @@ import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES+import Data.Key (mapWithKeyM_) import Data.List import Data.Maybe import qualified Data.Ord as Ord +import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState@@ -29,6 +30,8 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Frontend import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI) import Game.LambdaHack.Server.Config@@ -39,40 +42,28 @@ import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.Assert --- | Start a clip (a part of a turn for which one or more frames--- will be generated). Do whatever has to be done--- every fixed number of time units, e.g., monster generation.--- Run the leader and other actors moves. Eventually advance the time--- and repeat.+-- | Start a game session. Loop, communicating with clients. loopSer :: (MonadAtomic m, MonadConnServer m)         => DebugModeSer         -> (CmdSer -> m Bool)-        -> (FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())-        -> (FactionId -> ChanServer CmdClientAI -> IO ())+        -> (FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer+            -> IO ())+        -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime+            -> IO ())         -> Kind.COps         -> m ()-loopSer sdebugNxt cmdSerSem executorUI executorAI !cops = do+loopSer sdebug cmdSerSem executorUI executorAI !cops = do   -- Recover states and launch clients.-  restored <- tryRestore cops+  restored <- tryRestore cops sdebug   case restored of-    Nothing -> do  -- Starting a new game.-      -- Set up commandline debug mode-      modifyServer $ \ser -> ser {sdebugNxt}-      s <- gameReset cops-      let speedup = speedupCOps (sallClear sdebugNxt)-      execCmdAtomic $ RestartServerA $ updateCOps speedup s-      applyDebug sdebugNxt-      updateConn executorUI executorAI-      initPer-      reinitGame-      -- Save ASAP in case of crashes and disconnects.-      saveBkpAll-    Just (sRaw, ser) -> do  -- Running a restored game.+    Just (sRaw, ser) | not $ snewGameSer sdebug -> do  -- run a restored game       -- First, set the previous cops, to send consistent info to clients.       let setPreviousCops = const cops       execCmdAtomic $ ResumeServerA $ updateCOps setPreviousCops sRaw-      putServer ser {sdebugNxt}-      applyDebug sdebugNxt+      putServer ser+      sdebugNxt <- initDebug sdebug+      modifyServer $ \ser2 -> ser2 {sdebugNxt}+      applyDebug       updateConn executorUI executorAI       initPer       pers <- getsServer sper@@ -82,23 +73,35 @@       -- @sRaw@ is correct here, because none of the above changes State.       execCmdAtomic $ ResumeServerA $ updateCOps setCurrentCops sRaw       initPer-  -- Loop, communicating with clients.+    _ -> do  -- Starting a new game.+      -- Set up commandline debug mode+      s <- gameReset cops sdebug+      sdebugNxt <- initDebug sdebug+      modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt}+      let speedup = speedupCOps (sallClear sdebugNxt)+      execCmdAtomic $ RestartServerA $ updateCOps speedup s+      updateConn executorUI executorAI+      initPer+      reinitGame+  resetSessionStart+  -- Start a clip (a part of a turn for which one or more frames+  -- will be generated). Do whatever has to be done+  -- every fixed number of time units, e.g., monster generation.+  -- Run the leader and other actors moves. Eventually advance the time+  -- and repeat.   let loop = do         let factionArena fact = do-              let spawn = isSpawnFact cops fact-                  -- TODO; This is a significant advantage of human spawners;-                  -- perhaps we could instead auto-switch leaders-                  -- to the fist level non-spawner factions act on.-                  isHuman = isHumanFact fact               case gleader fact of-                Just leader | isHuman || not spawn -> do+               -- Even spawners and horrors need an active arena+               -- for their leader, or they start clogging stairs.+               Just leader -> do                   b <- getsState $ getActorBody leader                   return $ Just $ blid b-                _ -> return Nothing+               _ -> return Nothing         factionD <- getsState sfactionD         marenas <- mapM factionArena $ EM.elems factionD         let arenas = ES.toList $ ES.fromList $ catMaybes marenas-        assert (not $ null arenas) skip  -- no 2 solo AI spawners scenario+        assert (not $ null arenas) skip  -- game over not caught earlier         mapM_ (handleActors cmdSerSem) arenas         quit <- getsServer squit         if quit then do@@ -107,43 +110,73 @@           modifyServer $ \ser -> ser {squit = False}           endOrLoop (updateConn executorUI executorAI) loop         else do-          endClip arenas-          loop+          continue <- endClip arenas+          when continue loop   loop -saveBkpAll :: (MonadAtomic m, MonadServer m) => m ()+initDebug :: MonadServer m => DebugModeSer -> m DebugModeSer+initDebug sdebugSer = do+  sconfig <- getsServer sconfig+  return $+    (\dbg -> dbg {sfovMode =+        sfovMode dbg `mplus` Just (configFovMode sconfig)}) .+    (\dbg -> dbg {ssavePrefixSer =+        ssavePrefixSer dbg `mplus` Just (configSavePrefix sconfig)})+    $ sdebugSer++-- This can be improved by adding a timeout and by asking clients to prepare+-- a save (in this way checking they have permissions, enough space, etc.)+-- and when all report back, asking them to commit the save.+-- | Save game on server and all clients. Clients are pinged first,+-- which greatly reduced the chance of saves being out of sync.+saveBkpAll :: (MonadAtomic m, MonadServer m, MonadConnServer m) => m () saveBkpAll = do+  factionD <- getsState sfactionD+  let ping fid _ = do+        sendPingAI fid+        when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid+  mapWithKeyM_ ping factionD   execCmdAtomic SaveBkpA-  saveGameBkp+  saveServer -endClip :: (MonadAtomic m, MonadServer m) => [LevelId] -> m ()+endClip :: (MonadAtomic m, MonadServer m, MonadConnServer m)+        => [LevelId] -> m Bool endClip arenas = do+  -- TODO: a couple messages each clip to many clients is too costly.+  -- Store these on a queue and sum times instead of sending,+  -- until a different command needs to be sent. Include HealActorA+  -- from regenerateLevelHP, but keep it before AgeGameA.+  -- TODO: this is also needed to keep savefiles small (undo info).+  mapM_ (\lid -> execCmdAtomic $ AgeLevelA lid timeClip) arenas+  execCmdAtomic $ AgeGameA timeClip+  -- Perform periodic dungeon maintenance.   time <- getsState stime   Config{configSaveBkpClips} <- getsServer sconfig   let clipN = time `timeFit` timeClip       cinT = let r = timeTurn `timeFit` timeClip              in assert (r > 2) r-      bkpFreq = cinT * configSaveBkpClips       clipMod = clipN `mod` cinT   bkpSave <- getsServer sbkpSave-  when (bkpSave || clipN `mod` bkpFreq == 0) $ do+  when (bkpSave || clipN `mod` configSaveBkpClips == 0) $ do     modifyServer $ \ser -> ser {sbkpSave = False}-    execCmdAtomic SaveBkpA-    saveGameBkp+    saveBkpAll   -- Regenerate HP and add monsters each turn, not each clip.   -- Do this on only one of the arenas to prevent micromanagement,   -- e.g., spreading leaders across levels to bump monster generation.-  when (clipMod == 1) $ do+  if clipMod == 1 then do     arena <- rndToAction $ oneOf arenas     regenerateLevelHP arena     generateMonster arena-  -- TODO: a couple messages each clip to many clients is too costly.-  -- Store these on a queue and sum times instead of sending,-  -- until a different command needs to be sent. Include HealActorA-  -- from regenerateLevelHP, but keep it before AgeGameA.-  -- TODO: this is also needed to keep savefiles small (undo info).-  mapM_ (\lid -> execCmdAtomic $ AgeLevelA lid timeClip) arenas-  execCmdAtomic $ AgeGameA timeClip+    sstopAfter <- getsServer $ sstopAfter . sdebugSer+    case sstopAfter of+      Nothing -> return True+      Just stopAfter -> do+        exit <- elapsedSessionTimeGT stopAfter+        if exit then do+          saveAndExit+          return False  -- don't re-enter the game loop+        else return True+  else return True  -- | Perform moves for individual actors, as long as there are actors -- with the next move time less than or equal to the current level time.@@ -155,9 +188,9 @@              -> LevelId              -> m () handleActors cmdSerSem lid = do-  Kind.COps{coactor} <- getsState scops+  Kind.COps{cofact=Kind.Ops{okind}} <- getsState scops   time <- getsState $ getLocalTime lid  -- the end of this clip, inclusive-  prio <- getsLevel lid lprio+  Level{lprio} <- getLevel lid   quit <- getsServer squit   factionD <- getsState sfactionD   s <- getState@@ -166,9 +199,9 @@       isLeader (aid, b) = Just aid /= gleader (factionD EM.! bfid b)       order = Ord.comparing $         ((>= 0) . bhp . snd) &&& bfid . snd &&& isLeader &&& bsymbol . snd-      (atime, as) = EM.findMin prio+      (atime, as) = EM.findMin lprio       ams = map (\a -> (a, getActorBody a s)) as-      mnext | EM.null prio = Nothing  -- no actor alive, wait until it spawns+      mnext | EM.null lprio = Nothing  -- no actor alive, wait until it spawns             | otherwise = if atime > time                           then Nothing  -- no actor is ready for another move                           else Just $ minimumBy order ams@@ -196,54 +229,81 @@       let side = bfid body           fact = factionD EM.! side           mleader = gleader fact-          usesAI = usesAIFact fact-          hasHumanLeader = isNothing $ gAiLeader fact-          queryUI = not usesAI || hasHumanLeader && Just aid == mleader-      -- TODO: check that the command is legal-      cmdS <- if queryUI then-                -- The client always displays a frame in this case.-                sendQueryUI side aid-              else do-                -- Order the UI client (if any) corresponding to the AI client-                -- to display a new frame so that player does not see moves-                -- of all his AI party members cumulated in a single frame,-                -- but one by one.-                execSfxAtomic $ DisplayPushD side-                sendQueryAI side aid-      let leaderNew = aidCmdSer cmdS-          leadAtoms =-            if leaderNew /= aid-            then -- Only leader can change leaders  -- TODO: effLvlGoUp changes-                 assert (mleader == Just aid)-                   [LeadFactionA side mleader (Just leaderNew)]-            else []-      mapM_ execCmdAtomic leadAtoms-      bPre <- getsState $ getActorBody leaderNew-      -- Check if the client cheats, trying to move other faction actors.-      assert (bfid bPre == side `blame` (bPre, side)) skip-      timed <--        if bhp bPre <= 0 && not (bproj bPre)-        then execFailure side "You strain, fumble and faint from the exertion."-        else cmdSerSem cmdS-      -- AI has to take time, otherwise it'd loop.-      assert (queryUI || timed `blame` (cmdS, timed, bPre)) skip-      -- Advance time once, after the leader switched perhaps many times.-      -- TODO: this is correct only when all heroes have the same-      -- speed and can't switch leaders by, e.g., aiming a wand-      -- of domination. We need to generalize by displaying-      -- "(next move in .3s [RET]" when switching leaders.-      -- RET waits .3s and gives back control,-      -- Any other key does the .3s wait and the action from the key-      -- at once.-      when timed $ advanceTime leaderNew-      -- Generate extra frames if the actor has already moved during-      -- this clip, so his multiple moves would be collapsed in one frame.-      -- If the actor changes his speed this very turn, the test can fail,-      -- but it's a minor UI issue, so let it be.-      let previousClipEnd = timeAdd time $ timeNegate timeClip-          lastSingleMove = timeAddFromSpeed coactor bPre previousClipEnd-      when (btime bPre > lastSingleMove) $-        broadcastSfxAtomic DisplayPushD+          queryUI | Just aid == mleader = not $ playerAiLeader $ gplayer fact+                  | otherwise = not $ playerAiOther $ gplayer fact+          switchLeader cmdS = do+            -- TODO: check that the command is legal first, report and reject,+            -- but do not crash (currently server asserts things and crashes)+            let leaderNew = aidCmdSer cmdS+                leadAtoms =+                  if leaderNew /= aid+                  then -- Only leader can change leaders+                       -- TODO: effLvlGoUp changes+                       assert (mleader == Just aid)+                         [LeadFactionA side mleader (Just leaderNew)]+                  else []+            mapM_ execCmdAtomic leadAtoms+            bPre <- getsState $ getActorBody leaderNew+            assert (bfid bPre == side+                    `blame` "client tries to move other faction actors"+                    `with` (bPre, side)) skip+            return (leaderNew, bPre)+          extraFrames bPre = do+            -- Generate extra frames if the actor has already moved during+            -- this clip, so his multiple moves would be collapsed+            -- in one frame.+            -- If the actor changes his speed this very turn,+            -- the test can fail, but it's a minor UI issue, so let it be.+            let previousClipEnd = timeAdd time $ timeNegate timeClip+                lastSingleMove = timeAddFromSpeed bPre previousClipEnd+            when (btime bPre > lastSingleMove) $+              broadcastSfxAtomic DisplayPushD+      if queryUI then do+        -- The client always displays a frame in this case.+        cmdS <- sendQueryUI side aid+        (leaderNew, bPre) <- switchLeader cmdS+        timed <-+          if bhp bPre <= 0 && not (bproj bPre) then do+            execSfxAtomic+              $ MsgFidD side "You strain, fumble and faint from the exertion."+            return False+          else cmdSerSem cmdS+        -- Advance time once, after the leader switched perhaps many times.+        -- TODO: this is correct only when all heroes have the same+        -- speed and can't switch leaders by, e.g., aiming a wand+        -- of domination. We need to generalize by displaying+        -- "(next move in .3s [RET]" when switching leaders.+        -- RET waits .3s and gives back control,+        -- Any other key does the .3s wait and the action from the key+        -- at once.+        when timed $ advanceTime leaderNew+        extraFrames bPre+      else do+        -- Order the UI client (if any) corresponding to the AI client+        -- to display a new frame so that player does not see moves+        -- of all his AI party members cumulated in a single frame,+        -- but one by one.+        execSfxAtomic $ DisplayPushD side+        -- Clear messages in the UI client (if any), if the actor+        -- is freely moving.+        let factionAbilities+              | Just aid == mleader = fAbilityLeader $ okind $ gkind fact+              | otherwise = fAbilityOther $ okind $ gkind fact+            canMove = playerUI (gplayer fact)+                      && not (bproj body)+                      && (Ability.Chase `elem` factionAbilities+                          || Ability.Wander `elem` factionAbilities)+        when canMove $ execSfxAtomic $ RecordHistoryD side+        cmdT <- sendQueryAI side aid+        let cmdS = TakeTimeSer cmdT+        (leaderNew, bPre) <- switchLeader cmdS+        assert (not (bhp bPre <= 0 && not (bproj bPre))+                `blame` "AI switches to an incapacitated actor"+                `with` (cmdS, bPre, side)) skip+        void $ cmdSerSem cmdS+        -- AI always takes time and so doesn't loop.+        advanceTime leaderNew+        extraFrames bPre       handleActors cmdSerSem lid  dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()@@ -267,13 +327,11 @@ -- | Advance the move time for the given actor. advanceTime :: MonadAtomic m => ActorId -> m () advanceTime aid = do-  Kind.COps{coactor} <- getsState scops   b <- getsState $ getActorBody aid   -- Don't update move time, so move ASAP, so the projectile   -- corpse vanishes ASAP.   unless (bhp b < 0 && bproj b || maybe False null (bpath b)) $ do-    let speed = actorSpeed coactor b-        t = ticksPerMeter speed+    let t = ticksPerMeter $ bspeed b     execCmdAtomic $ AgeActorA aid t  -- | Generate a monster, possibly.@@ -281,7 +339,7 @@ generateMonster lid = do   cops <- getsState scops   pers <- getsServer sper-  lvl@Level{ldepth} <- getsLevel lid id+  lvl@Level{ldepth} <- getLevel lid   s <- getState   let f fid = isSpawnFaction fid s       spawns = actorNotProjList f lid s@@ -298,20 +356,21 @@ rollSpawnPos Kind.COps{cotile} visible lid Level{ltile, lxsize, lysize} s = do   let factionDist = max lxsize lysize - 5       inhabitants = actorNotProjList (const True) lid s+      as = actorList (const True) lid s       isLit = Tile.isLit cotile       distantAtLeast d p _ =         all (\b -> chessDist lxsize (bpos b) p > d) inhabitants   findPosTry 40 ltile-    [ \ _ t -> not (isLit t)  -- no such tiles on some maps+    [ \_ t -> not (isLit t)  -- no such tiles on some maps     , distantAtLeast factionDist     , distantAtLeast $ factionDist `div` 2-    , \ p _ -> not $ p `ES.member` visible+    , \p _ -> not $ p `ES.member` visible     , distantAtLeast $ factionDist `div` 3-    , \ _ t -> Tile.hasFeature cotile F.CanActor t  -- in reachable area+    , \_ t -> Tile.hasFeature cotile F.CanActor t  -- in reachable area     , distantAtLeast $ factionDist `div` 4     , distantAtLeast 3  -- otherwise a fast actor can walk and hit in one turn-    , \ p t -> Tile.hasFeature cotile F.Walkable t-               && unoccupied (actorList (const True) lid s) p+    , \p t -> Tile.hasFeature cotile F.Walkable t+              && unoccupied as p     ]  -- TODO: generalize to any list of items (or effects) applied to all actors@@ -352,7 +411,6 @@ -- | Continue or exit or restart the game. endOrLoop :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m () endOrLoop updConn loopServer = do-  cops <- getsState scops   factionD <- getsState sfactionD   let inGame fact = case gquit fact of         Nothing -> True@@ -368,39 +426,45 @@         _ -> False       campers = filter (isCamper . snd) $ EM.assocs factionD   case (quitters, campers) of-    (t : _, _) -> do-      modifyServer $ \ser -> ser {scenario = t}+    (sgameMode : _, _) -> do+      modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}}       restartGame updConn loopServer     _ | gameOver -> restartGame updConn loopServer     (_, []) -> loopServer  -- continue current game-    (_, _ : _) -> do  -- save game and exit+    (_, _ : _) -> do       -- Wipe out the quit flag for the savegame files.       mapM_ (\(fid, fact) ->               execCmdAtomic               $ QuitFactionA fid Nothing (gquit fact) Nothing) campers-      -- Save client and server data.-      execCmdAtomic SaveExitA-      saveGameSer-      -- Kill all clients, including those that did not take part-      -- in the current game.-      -- Clients exit not now, but after they print all ending screens.-      killAllClients-      -- Verify that the saved perception is equal to future reconstructed.-      persSaved <- getsServer sper-      configFov <- fovMode-      pers <- getsState $ dungeonPerception cops configFov-      assert (persSaved == pers `blame` (persSaved, pers)) skip+      saveAndExit       -- Don't call @loopServer@, that is, quit the game loop. +saveAndExit :: (MonadAtomic m, MonadConnServer m) => m ()+saveAndExit = do+  cops <- getsState scops+  -- Save client and server data.+  saveBkpAll+  -- Kill all clients, including those that did not take part+  -- in the current game.+  -- Clients exit not now, but after they print all ending screens.+  killAllClients+  -- Verify that the saved perception is equal to future reconstructed.+  persSaved <- getsServer sper+  fovMode <- getsServer $ sfovMode . sdebugSer+  pers <- getsState $ dungeonPerception cops+                                        (fromMaybe (Digital 12) fovMode)+  assert (persSaved == pers `blame` "wrong saved perception"+                            `with` (persSaved, pers)) skip+ restartGame :: (MonadAtomic m, MonadConnServer m)             => m () -> m () -> m () restartGame updConn loopServer = do   cops <- getsState scops-  s <- gameReset cops+  sdebugNxt <- getsServer sdebugNxt+  s <- gameReset cops sdebugNxt+  modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt}   execCmdAtomic $ RestartServerA s   updConn   initPer   reinitGame-  -- Save ASAP in case of crashes and disconnects.-  saveBkpAll   loopServer
Game/LambdaHack/Server/ServerSem.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Semantics of 'CmdSer' server commands. -- A couple of them do not take time, the rest does. -- Note that since the results are atomic commands, which are executed@@ -32,6 +31,7 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time@@ -46,10 +46,16 @@ import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.Assert -execFailure :: MonadAtomic m => FactionId -> Msg -> m Bool-execFailure fid msg = do-  execSfxAtomic $ MsgFidD fid msg-  return False+execFailure :: (MonadAtomic m, MonadServer m)+            => Actor -> FailureSer -> m ()+execFailure body failureSer = do+  -- Clients should rarely do that (only in case of invisible actors)+  -- so we report it, send a --more-- meeesage (if not AI), but do not crash+  -- (server should work OK with stupid clients, too).+  let fid = bfid body+      msg = showFailureSer failureSer+  debugPrint $ "execFailure:" <+> showT fid <+> ":" <+> msg+  execSfxAtomic $ MsgFidD fid msg  -- TODO: --more--  broadcastCmdAtomic :: MonadAtomic m                    => (FactionId -> CmdAtomic) -> m ()@@ -65,36 +71,10 @@  -- * MoveSer --- | Actor moves or attacks or searches or opens doors.--- Note that client can't determine which of these actions is chosen,--- because foes can be invisible, doors hidden, clients can move--- simultaneously during the same turn, etc. Also, only the server--- is authorized to check if a move is legal and it needs full context--- for that, e.g., the initial actor position to check if melee attack--- does not try to reach to a distant tile.-moveSer :: (MonadAtomic m, MonadServer m)-        => ActorId -> Vector -> Bool -> m Bool-moveSer aid dir exploration = do-  cops <- getsState scops-  sm <- getsState $ getActorBody aid-  lvl <- getsLevel (blid sm) id-  let spos = bpos sm           -- source position-      tpos = spos `shift` dir  -- target position-  -- We start by looking at the target position.-  let lid = blid sm-  tgt <- getsState (posToActor tpos lid)-  case tgt of-    Just target -> do-      -- Attacking does not require full access, adjacency is enough.-      actorAttackActor aid target-      return True-    Nothing-      | accessible cops lvl spos tpos -> do-          execCmdAtomic $ MoveActorA aid spos tpos-          addSmell aid-          return True-      | otherwise ->  -- try to open a door or explore a possible door-          actorOpenDoor aid dir exploration+checkAdjacent :: MonadActionRO m => Actor -> Actor -> m Bool+checkAdjacent sb tb = do+  Level{lxsize} <- getLevel $ blid sb+  return $ blid sb == blid tb && adjacent lxsize (bpos sb) (bpos tb)  -- TODO: let only some actors/items leave smell, e.g., a Smelly Hide Armour. -- | Add a smell trace for the actor to the level. For now, all and only@@ -107,156 +87,194 @@   let canSmell = asmell $ okind $ bkind b   unless (bproj b || spawn || canSmell) $ do     time <- getsState $ getLocalTime $ blid b-    oldS <- getsLevel (blid b) $ EM.lookup (bpos b) . lsmell-    let newTime = timeAdd time smellTimeout+    lvl <- getLevel $ blid b+    let oldS = EM.lookup (bpos b) . lsmell $ lvl+        newTime = timeAdd time smellTimeout     execCmdAtomic $ AlterSmellA (blid b) (bpos b) oldS (Just newTime) +-- | Actor moves or attacks.+-- Note that client may not be able to see an invisible monster+-- so it's the server that determines if melee took place, etc.+-- Also, only the server is authorized to check if a move is legal+-- and it needs full context for that, e.g., the initial actor position+-- to check if melee attack does not try to reach to a distant tile.+moveSer :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()+moveSer source dir = do+  cops <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+  lvl <- getLevel lid+  let spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+  -- We start by checking actors at the the target position.+  tgt <- getsState $ posToActor tpos lid+  case tgt of+    Just target ->  -- visible or not+      -- Attacking does not require full access, adjacency is enough.+      meleeSer source target+    Nothing+      | accessible cops lvl spos tpos -> do+          -- Movement requires full access.+          execCmdAtomic $ MoveActorA source spos tpos+          addSmell source+      | otherwise ->+          -- Client foolishly tries to move into blocked, boring tile.+          execFailure sb MoveNothing++-- * MeleeSer+ -- | Resolves the result of an actor moving into another. -- Actors on blocked positions can be attacked without any restrictions. -- For instance, an actor embedded in a wall can be attacked from -- an adjacent position. This function is analogous to projectGroupItem, -- but for melee and not using up the weapon.-actorAttackActor :: (MonadAtomic m, MonadServer m)-                 => ActorId -> ActorId -> m ()-actorAttackActor source target = do+meleeSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()+meleeSer source target = do   cops@Kind.COps{coitem=Kind.Ops{opick, okind}} <- getsState scops-  sm <- getsState (getActorBody source)-  tm <- getsState (getActorBody target)-  let sfid = bfid sm-      tfid = bfid tm-  time <- getsState $ getLocalTime (blid tm)-  s <- getState-  itemAssocs <- getsState $ getActorItem source-  (miid, item) <--    if bproj sm-    then case itemAssocs of-      [(iid, item)] -> return (Just iid, item)  -- projectile-      _ -> assert `failure` itemAssocs-    else case strongestSword cops itemAssocs of-      Just (_, (iid, w)) -> return (Just iid, w)-      Nothing -> do  -- hand to hand combat-        let h2hGroup | isSpawnFaction sfid s = "monstrous"-                     | otherwise = "unarmed"-        h2hKind <- rndToAction $ opick h2hGroup (const True)-        flavour <- getsServer sflavour-        discoRev <- getsServer sdiscoRev-        let kind = okind h2hKind-            effect = fmap (maxDice . fst) (ieffect kind)-        return ( Nothing-               , buildItem flavour discoRev h2hKind kind effect )-  let performHit block = do-        let hitA = if block then HitBlockD else HitD-        execSfxAtomic $ StrikeD source target item hitA-        -- Deduct a hitpoint for a pierce of a projectile.-        when (bproj sm) $ execCmdAtomic $ HealActorA source (-1)-        -- Msgs inside itemEffectSem describe the target part.-        itemEffect source target miid item-  -- Projectiles can't be blocked (though can be sidestepped).-  -- Incapacitated actors can't block-  if braced tm time && not (bproj sm) && bhp tm > 0-    then do-      blocked <- rndToAction $ chance $ 1%2-      if blocked-        then execSfxAtomic $ StrikeD source target item MissBlockD-        else performHit True-    else performHit False-  sfact <- getsState $ (EM.! sfid) . sfactionD-  -- The only way to start a war is to slap an enemy. Being hit by-  -- and hitting projectiles count as unintentional friendly fire.-  let friendlyFire = bproj sm || bproj tm-      fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)-  unless (friendlyFire || isAtWar sfact tfid || sfid == tfid) $-    execCmdAtomic $ DiplFactionA sfid tfid fromDipl War---- TODO: bumpTile tpos F.Openable--- | An actor opens a door.-actorOpenDoor :: (MonadAtomic m, MonadServer m)-              => ActorId -> Vector -> Bool -> m Bool-actorOpenDoor aid dir exploration = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  let dpos = shift (bpos body) dir  -- the position we act upon-      lid = blid body-  lvl <- getsLevel lid id-  let serverTile = lvl `at` dpos-      freshClientTile = hideTile cotile dpos lvl-      -- TODO: running doesn't open doors if they are hidden,-      -- even if known to the actor. No apparent way to solve that.-      t | exploration = serverTile  -- will be found-        | otherwise   = freshClientTile  -- won't be searched-  -- Try to open the door.-  if Tile.hasFeature cotile F.Openable t-    then triggerSer aid dpos  -- searches, too-    else do-      when (exploration && serverTile /= freshClientTile) $-        execCmdAtomic $ SearchTileA aid dpos freshClientTile serverTile-      if Tile.hasFeature cotile F.Closable t-        then execFailure (bfid body) "already open"-        else if exploration && serverTile /= freshClientTile-             then return True  -- searching costs-                  -- TODO: don't add to history (add a flag to report msgs)-             else execFailure (bfid body) "never mind"  -- free bump+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  adj <- checkAdjacent sb tb+  if not adj then execFailure sb MeleeDistant+  else do+    let sfid = bfid sb+        tfid = bfid tb+    time <- getsState $ getLocalTime (blid tb)+    itemAssocs <- getsState $ getActorItem source+    (miid, item) <-+      if bproj sb   -- projectile+      then case itemAssocs of+        [(iid, item)] -> return (Just iid, item)+        _ -> assert `failure` "projectile with wrong items" `with` itemAssocs+      else case strongestSword cops itemAssocs of+        Just (_, (iid, w)) -> return (Just iid, w)  -- weapon combat+        Nothing -> do  -- hand to hand combat+          isSp <- getsState $ isSpawnFaction sfid+          let h2hGroup | isSp = "monstrous"+                       | otherwise = "unarmed"+          h2hKind <- rndToAction $ opick h2hGroup (const True)+          flavour <- getsServer sflavour+          discoRev <- getsServer sdiscoRev+          let kind = okind h2hKind+              effect = fmap (maxDice . fst) (ieffect kind)+          return ( Nothing+                 , buildItem flavour discoRev h2hKind kind effect )+    let performHit block = do+          let hitA = if block then HitBlockD else HitD+          execSfxAtomic $ StrikeD source target item hitA+          -- Deduct a hitpoint for a pierce of a projectile.+          when (bproj sb) $ execCmdAtomic $ HealActorA source (-1)+          -- Msgs inside itemEffectSem describe the target part.+          itemEffect source target miid item+    -- Projectiles can't be blocked (though can be sidestepped).+    -- Incapacitated actors can't block.+    if braced tb time && not (bproj sb) && bhp tb > 0+      then do+        blocked <- rndToAction $ chance $ 1%2+        if blocked+          then execSfxAtomic $ StrikeD source target item MissBlockD+          else performHit True+      else performHit False+    sfact <- getsState $ (EM.! sfid) . sfactionD+    -- The only way to start a war is to slap an enemy. Being hit by+    -- and hitting projectiles count as unintentional friendly fire.+    let friendlyFire = bproj sb || bproj tb+        fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)+    unless (friendlyFire || isAtWar sfact tfid || sfid == tfid) $+      execCmdAtomic $ DiplFactionA sfid tfid fromDipl War --- * RunSer+-- * DisplaceSer --- | Actor moves or swaps position with others or opens doors.-runSer :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m Bool-runSer aid dir = do+-- | Actor tries to swap positions with another.+displaceSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()+displaceSer source target = do   cops <- getsState scops-  sm <- getsState $ getActorBody aid-  lvl <- getsLevel (blid sm) id-  let spos = bpos sm           -- source position-      tpos = spos `shift` dir  -- target position-  -- We start by looking at the target position.-  let lid = blid sm-  tgt <- getsState (posToActor tpos lid)-  case tgt of-    Just target-      | accessible cops lvl spos tpos -> do-          -- Switching positions requires full access.-          displaceActor aid target-          return True-      | otherwise ->-          execFailure (bfid sm) "blocked"-    Nothing-      | accessible cops lvl spos tpos -> do-          execCmdAtomic $ MoveActorA aid spos tpos-          addSmell aid-          return True-      | otherwise ->-          actorOpenDoor aid dir False  -- no exploration when running+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  adj <- checkAdjacent sb tb+  if not adj then execFailure sb DisplaceDistant+  else do+    let lid = blid sb+    lvl <- getLevel lid+    let spos = bpos sb+        tpos = bpos tb+    if accessible cops lvl spos tpos then do+      -- Displacing requires full access.+      execCmdAtomic $ DisplaceActorA source target+      addSmell source+    else do+      -- Client foolishly tries to displace an actor without access.+      execFailure sb DisplaceAccess --- | When an actor runs (not walks) into another, they switch positions.-displaceActor :: MonadAtomic m-              => ActorId -> ActorId -> m ()-displaceActor source target = do-  execCmdAtomic $ DisplaceActorA source target-  addSmell source---  leader <- getsClient getLeader---  if Just source == leader--- TODO: The actor will stop running due to the message as soon as running--- is fixed to check the message before it goes into history.---   then stopRunning  -- do not switch positions repeatedly---   else void $ focusIfOurs target+-- * AlterSer +-- | Search and/or alter the tile.+--+-- Note that if @serverTile /= freshClientTile@, @freshClientTile@+-- should not be alterable (but @serverTile@ may be).+alterSer :: (MonadAtomic m, MonadServer m)+         => ActorId -> Point -> Maybe F.Feature -> m ()+alterSer source tpos mfeat = do+  Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+      spos = bpos sb+  Level{lxsize} <- getLevel lid+  if not $ adjacent lxsize spos tpos then execFailure sb AlterDistant+  else do+    lvl <- getLevel lid+    let serverTile = lvl `at` tpos+        freshClientTile = hideTile cotile lvl tpos+        changeTo tgroup = do+          -- No AlterD, because the effect is obvious (e.g., opened door).+          toTile <- rndToAction $ opick tgroup (const True)+          unless (toTile == serverTile) $+            execCmdAtomic $ AlterTileA lid tpos serverTile toTile+        feats = case mfeat of+          Nothing -> TileKind.tfeature $ okind serverTile+          Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]+          Just _ -> []+        toAlter feat =+          case feat of+            F.OpenTo tgroup -> Just tgroup+            F.CloseTo tgroup -> Just tgroup+            F.ChangeTo tgroup -> Just tgroup+            _ -> Nothing+        groupsToAlter = mapMaybe toAlter feats+    as <- getsState $ actorList (const True) lid+    if null groupsToAlter && serverTile == freshClientTile then+      -- Neither searching nor altering possible; silly client.+      execFailure sb AlterNothing+    else do+      if EM.null $ lvl `atI` tpos then+        if unoccupied as tpos then do+          when (serverTile /= freshClientTile) $ do+            -- Search, in case some actors (of other factions?)+            -- don't know this tile.+            execCmdAtomic $ SearchTileA source tpos freshClientTile serverTile+          mapM_ changeTo groupsToAlter+          -- Perform an effect, if any permitted.+          void $ triggerEffect source feats+        else execFailure sb AlterBlockActor+      else execFailure sb AlterBlockItem+ -- * WaitSer  -- | Update the wait/block count. Uses local, per-level time, -- to remain correct even if the level is frozen for some global time turns. waitSer :: MonadAtomic m => ActorId -> m () waitSer aid = do-  Kind.COps{coactor} <- getsState scops   body <- getsState $ getActorBody aid   time <- getsState $ getLocalTime $ blid body   let fromWait = bwait body-      toWait = timeAddFromSpeed coactor body time+      toWait = timeAddFromSpeed body time   execCmdAtomic $ WaitActorA aid fromWait toWait  -- * PickupSer  pickupSer :: MonadAtomic m           => ActorId -> ItemId -> Int -> InvChar -> m ()-pickupSer aid iid k l = assert (k > 0 `blame` (aid, iid, k, l)) $ do+pickupSer aid iid k l = assert (k > 0 `blame` "pick up no items"+                                      `with` (aid, iid, k, l)) $ do   b <- getsState $ getActorBody aid   execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) (CActor aid l) @@ -277,45 +295,58 @@            -> Int        -- ^ digital line parameter            -> ItemId     -- ^ the item to be projected            -> Container  -- ^ whether the items comes from floor or inventory-           -> m Bool+           -> m () projectSer source tpos eps iid container = do-  cops <- getsState scops-  sm <- getsState (getActorBody source)-  Actor{btime} <- getsState $ getActorBody source-  lvl <- getsLevel (blid sm) id-  lxsize <- getsLevel (blid sm) lxsize-  lysize <- getsLevel (blid sm) lysize-  let spos = bpos sm-      lid = blid sm+  Kind.COps{cotile} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+      spos = bpos sb+  fact <- getsState $ (EM.! bfid sb) . sfactionD+  Level{lxsize, lysize} <- getLevel lid+  foes <- getsState $ actorNotProjList (isAtWar fact) lid+  if foesAdjacent lxsize lysize spos foes+    then execFailure sb ProjectBlockFoes+    else do+      case bla lxsize lysize eps spos tpos of+        Nothing -> execFailure sb ProjectAimOnself+        Just [] -> assert `failure` "projecting from the edge of level"+                          `with` (spos, tpos)+        Just (pos : rest) -> do+          as <- getsState $ actorList (const True) lid+          lvl <- getLevel lid+          let t = lvl `at` pos+          if not $ Tile.hasFeature cotile F.Clear t+            then execFailure sb ProjectBlockTerrain+            else if unoccupied as pos+                 then projectBla source pos rest iid container+                 else execFailure sb ProjectBlockActor++projectBla :: (MonadAtomic m, MonadServer m)+           => ActorId    -- ^ actor projecting the item (is on current lvl)+           -> Point      -- ^ starting point of the projectile+           -> [Point]    -- ^ rest of the path of the projectile+           -> ItemId     -- ^ the item to be projected+           -> Container  -- ^ whether the items comes from floor or inventory+           -> m ()+projectBla source pos rest iid container = do+  sb <- getsState $ getActorBody source+  let lid = blid sb       -- A bit later than actor time, to prevent a move this turn.-      time = btime `timeAdd` timeEpsilon-      -- TODO: AI should choose the best eps.-      bl = bla lxsize lysize eps spos tpos-  case bl of-    Nothing -> execFailure (bfid sm) "cannot zap oneself"-    Just [] -> assert `failure`-                 (spos, tpos, "project from the edge of level" :: Text)-    Just path@(pos:_) -> do-      inhabitants <- getsState (posToActor pos lid)-      if accessible cops lvl spos pos && isNothing inhabitants-        then do-          execSfxAtomic $ ProjectD source iid-          projId <- addProjectile iid pos (blid sm) (bfid sm) path time-          execCmdAtomic-            $ MoveItemA iid 1 container (CActor projId (InvChar 'a'))-          return True-        else-          execFailure (bfid sm) "blocked"+      time = btime sb `timeAdd` timeEpsilon+  execSfxAtomic $ ProjectD source iid+  projId <- addProjectile pos rest iid lid (bfid sb) time+  execCmdAtomic $ MoveItemA iid 1 container (CActor projId (InvChar 'a'))  -- | Create a projectile actor containing the given missile. addProjectile :: (MonadAtomic m, MonadServer m)-              => ItemId -> Point -> LevelId -> FactionId -> [Point] -> Time+              => Point -> [Point] -> ItemId -> LevelId -> FactionId -> Time               -> m ActorId-addProjectile iid bpos blid bfid path btime = do-  Kind.COps{coactor, coitem=coitem@Kind.Ops{okind}} <- getsState scops+addProjectile bpos rest iid blid bfid btime = do+  Kind.COps{ coactor=coactor@Kind.Ops{okind}+           , coitem=coitem@Kind.Ops{okind=iokind} } <- getsState scops   disco <- getsServer sdisco   item <- getsState $ getItemBody iid-  let ik = okind (fromJust $ jkind disco item)+  let ik = iokind (fromJust $ jkind disco item)       speed = speedFromWeight (iweight ik) (itoThrow ik)       range = rangeFromSpeed speed       adj | range < 5 = "falling"@@ -323,9 +354,11 @@       -- Not much details about a fast flying object.       (object1, object2) = partItem coitem EM.empty item       name = makePhrase [MU.AW $ MU.Text adj, object1, object2]-      dirPath = take range $ displacePath path-      m = actorTemplate (projectileKindId coactor) Nothing (Just name) Nothing-                        (Just speed) 0 (Just dirPath) bpos blid btime bfid True+      dirPath = take range $ displacePath (bpos : rest)+      kind = okind $ projectileKindId coactor+      m = actorTemplate (projectileKindId coactor) (asymbol kind) name+                        (acolor kind) speed 0 (Just dirPath)+                        bpos blid btime bfid True   acounter <- getsServer sacounter   modifyServer $ \ser -> ser {sacounter = succ acounter}   execCmdAtomic $ CreateActorA acounter m [(iid, item)]@@ -347,41 +380,38 @@  -- * TriggerSer --- | Perform the action specified for the tile in case it's triggered.+-- | Perform the effect specified for the tile in case it's triggered. triggerSer :: (MonadAtomic m, MonadServer m)-           => ActorId -> Point -> m Bool-triggerSer aid dpos = do-  Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops-  b <- getsState $ getActorBody aid-  let lid = blid b-  lvl <- getsLevel lid id-  let serverTile = lvl `at` dpos-      freshClientTile = hideTile cotile dpos lvl-  when (serverTile /= freshClientTile) $-    -- Search, in case some actors (of other factions?) don't know this tile.-    execCmdAtomic $ SearchTileA aid dpos freshClientTile serverTile-  let f feat =+           => ActorId -> Maybe F.Feature -> m ()+triggerSer aid mfeat = do+  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops+  sb <- getsState $ getActorBody aid+  let lid = blid sb+  lvl <- getLevel lid+  let tpos = bpos sb+      serverTile = lvl `at` tpos+      feats = case mfeat of+        Nothing -> TileKind.tfeature $ okind serverTile+        Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]+        Just _ -> []+  go <- triggerEffect aid feats+  unless go $ execFailure sb TriggerNothing++triggerEffect :: (MonadAtomic m, MonadServer m)+              => ActorId -> [F.Feature] -> m Bool+triggerEffect aid feats = do+  sb <- getsState $ getActorBody aid+  let tpos = bpos sb+      triggerFeat feat =         case feat of           F.Cause ef -> do             -- No block against tile, hence unconditional.-            execSfxAtomic $ TriggerD aid dpos feat {-TODO-}True+            execSfxAtomic $ TriggerD aid tpos feat             void $ effectSem ef aid aid             return True-          F.ChangeTo tgroup -> do-            execSfxAtomic $ TriggerD aid dpos feat {-TODO-}True-            as <- getsState $ actorList (const True) lid-            if EM.null $ lvl `atI` dpos-              then if unoccupied as dpos-                 then do-                   toTile <- rndToAction $ opick tgroup (const True)-                   execCmdAtomic $ AlterTileA lid dpos serverTile toTile-                   return True--- TODO: take care of AI using this function (aborts on some of the features, succes on others, etc.)-                 else execFailure (bfid b) "blocked"  -- by actors-            else execFailure (bfid b) "jammed"  -- by items           _ -> return False-  bs <- mapM f $ TileKind.tfeature $ okind serverTile-  return $! or bs  -- TODO: stop after first failure, probably+  goes <- mapM triggerFeat feats+  return $! or goes  -- * SetPathSer @@ -390,14 +420,14 @@ setPathSer aid path = do   when (length path <= 2) $ do     fromColor <- getsState $ bcolor . getActorBody aid-    let toColor = Just Color.BrBlack+    let toColor = Color.BrBlack     when (fromColor /= toColor) $       execCmdAtomic $ ColorActorA aid fromColor toColor   fromPath <- getsState $ bpath . getActorBody aid   case path of     [] -> execCmdAtomic $ PathActorA aid fromPath (Just [])     d : lv -> do-      void $ moveSer aid d False+      void $ moveSer aid d       execCmdAtomic $ PathActorA aid fromPath (Just lv)  -- * GameRestart
Game/LambdaHack/Server/StartAction.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Operations for starting and restarting the game. module Game.LambdaHack.Server.StartAction   ( applyDebug, gameReset, reinitGame, initPer@@ -10,6 +9,7 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Key (mapWithKeyM_)+import Data.List import qualified Data.Map.Strict as M import Data.Maybe import Data.Text (Text)@@ -32,8 +32,8 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI) import Game.LambdaHack.Server.Config@@ -45,19 +45,24 @@ import Game.LambdaHack.Utils.Assert  -- | Apply debug options that don't need a new game.-applyDebug :: MonadServer m => DebugModeSer -> m ()-applyDebug sdebugNxt =+applyDebug :: MonadServer m => m ()+applyDebug = do+  DebugModeSer{..} <- getsServer sdebugNxt   modifyServer $ \ser ->-    ser {sdebugSer = (sdebugSer ser) { sniffIn = sniffIn sdebugNxt-                                     , sniffOut = sniffOut sdebugNxt-                                     , sallClear = sallClear sdebugNxt-                                     , stryFov = stryFov sdebugNxt }}+    ser {sdebugSer = (sdebugSer ser) { sniffIn+                                     , sniffOut+                                     , sallClear+                                     , sfovMode+                                     , sstopAfter+                                     , sdbgMsgSer+                                     , snewGameSer+                                     , sdebugCli }}  initPer :: MonadServer m => m () initPer = do   cops <- getsState scops-  configFov <- fovMode-  pers <- getsState $ dungeonPerception cops configFov+  fovMode <- getsServer $ sfovMode . sdebugSer+  pers <- getsState $ dungeonPerception cops (fromMaybe (Digital 12) fovMode)   modifyServer $ \ser1 -> ser1 {sper = pers}  reinitGame :: (MonadAtomic m, MonadServer m) => m ()@@ -77,9 +82,9 @@       sdisco = let f ik = isymbol (okind ik) `notElem` misteriousSymbols                in EM.filter f discoS   sdebugCli <- getsServer $ sdebugCli . sdebugSer-  t <- getsServer scenario+  modeName <- getsServer $ sgameMode . sdebugSer   broadcastCmdAtomic-    $ \fid -> RestartA fid sdisco (pers EM.! fid) defLoc sdebugCli t+    $ \fid -> RestartA fid sdisco (pers EM.! fid) defLoc sdebugCli modeName   populateDungeon  mapFromInvFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a@@ -94,41 +99,33 @@ lowercase = T.pack . map Char.toLower . T.unpack  createFactions :: Kind.COps -> Players -> Rnd FactionDict-createFactions Kind.COps{ cofact=Kind.Ops{opick, okind}-                        , costrat=Kind.Ops{opick=sopick} } players = do-  let rawCreate isHuman Player{ playerName = gconfig-                              , playerKind-                              , playerInitial = ginitial-                              , playerEntry = gentry } = do+createFactions Kind.COps{cofact=Kind.Ops{opick}} players = do+  let rawCreate gplayer@Player{..} = do         let cmap = mapFromInvFuns                      [colorToTeamName, colorToPlainName, colorToFancyName]-            nameoc = lowercase gconfig-            prefix | isHuman = "Human"+            nameoc = lowercase playerName+            prefix | playerHuman = "Human"                    | otherwise = "Autonomous"             (gcolor, gname) = case M.lookup nameoc cmap of-              Nothing -> (Color.BrWhite, prefix <+> gconfig)-              Just c -> (c, prefix <+> gconfig <+> "Team")-        gkind <- opick playerKind (const True)-        let fk = okind gkind-            gdipl = EM.empty  -- fixed below+              Nothing -> (Color.BrWhite, prefix <+> playerName)+              Just c -> (c, prefix <+> playerName <+> "Team")+        gkind <- opick playerFaction (const True)+        let gdipl = EM.empty  -- fixed below             gquit = Nothing-        gAiLeader <--          if isHuman-          then return Nothing-          else fmap Just $ sopick (fAiLeader fk) (const True)-        gAiMember <- fmap Just $ sopick (fAiMember fk) (const True)-        let gleader = Nothing+            gleader = Nothing         return Faction{..}-  lHuman <- mapM (rawCreate True) (playersHuman players)-  lComputer <- mapM (rawCreate False) (playersComputer players)-  let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lComputer)  -- sorted-            ++ zip [toEnum 1..] lHuman+  lUI <- mapM rawCreate $ filter playerUI $ playersList players+  lnoUI <- mapM rawCreate $ filter (not . playerUI) $ playersList players+  let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI)  -- sorted+            ++ zip [toEnum 1..] lUI       swapIx l =-        let ixs =-              let f (name1, name2) =-                    [ (ix1, ix2) | (ix1, fact1) <- lFs, gconfig fact1 == name1-                                 , (ix2, fact2) <- lFs, gconfig fact2 == name2]-              in concatMap f l+        let findPlayerName name = find ((name ==) . playerName . gplayer . snd)+            f (name1, name2) =+              case (findPlayerName name1 lFs, findPlayerName name2 lFs) of+                (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2)+                _ -> assert `failure` "unknown faction"+                            `with` ((name1, name2), lFs)+            ixs = map f l         -- Only symmetry is ensured, everything else is permitted, e.g.,         -- a faction in alliance with two others that are at war.         in ixs ++ map swap ixs@@ -143,40 +140,32 @@       warFs = mkDipl War allianceFs (swapIx (playersEnemy players))   return warFs -gameReset :: MonadServer m => Kind.COps -> m State-gameReset cops@Kind.COps{coitem, corule} = do+gameReset :: MonadServer m => Kind.COps -> DebugModeSer -> m State+gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}, corule}+          sdebug = do   -- Rules config reloaded at each new game start.   -- Taking the original config from config file, to reroll RNG, if needed   -- (the current config file has the RNG rolled for the previous game).   (sconfig, dungeonSeed, srandom) <- mkConfigRules corule-  t <- getsServer scenario   scoreTable <- restoreScore sconfig-  let rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev,+  sstart <- getsServer sstart  -- copy over from previous game+  let smode = sgameMode sdebug+      rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev,                   DungeonGen.FreshDungeon)       rnd = do-        let scenario = case M.lookup t $ configScenario sconfig of-              Just sc -> sc-              Nothing -> assert `failure` "no scenario configuration:" <+> t-            dng = scenarioDungeon scenario-            caves = case M.lookup dng $ configCaves sconfig of-              Just cv -> cv-              Nothing -> assert `failure` "no caves configuration:" <+> dng-            plr = scenarioPlayers scenario-            players = case M.lookup plr $ configPlayers sconfig of-              Just pl -> pl-              Nothing -> assert `failure` "no players configuration:" <+> plr-        faction <- createFactions cops players+        modeKind <- opick smode (const True)+        let mode = okind modeKind+        faction <- createFactions cops $ mplayers mode         sflavour <- dungeonFlavourMap coitem         (sdisco, sdiscoRev) <- serverDiscos coitem-        freshDng <- DungeonGen.dungeonGen cops caves+        freshDng <- DungeonGen.dungeonGen cops $ mcaves mode         return (faction, sflavour, sdisco, sdiscoRev, freshDng)   let (faction, sflavour, sdisco, sdiscoRev, DungeonGen.FreshDungeon{..}) =         St.evalState rnd dungeonSeed       defState = defStateGlobal freshDungeon freshDepth faction cops scoreTable       defSer = emptyStateServer-                 {sdisco, sdiscoRev, sflavour, srandom, scenario = t, sconfig}-  sdebugNxt <- getsServer sdebugNxt-  putServer defSer {sdebugNxt, sdebugSer = sdebugNxt}+                 {sdisco, sdiscoRev, sflavour, srandom, sconfig, sstart}+  putServer defSer   return defState  -- Spawn initial actors. Clients should notice this, to set their leaders.@@ -195,24 +184,27 @@   let (minD, maxD) =         case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` dungeon+          _ -> assert `failure` "empty dungeon" `with` dungeon       needInitialCrew = EM.assocs factionD-      getEntryLevel (_, fact) = max minD $ min maxD $ gentry fact+      getEntryLevel (_, fact) =+        max minD $ min maxD $ playerEntry $ gplayer fact       arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew       initialActors lid = do-        lvl <- getsLevel lid id+        lvl <- getLevel lid         let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew         entryPoss <- rndToAction                      $ findEntryPoss cops lvl (length arenaFactions)         mapM_ (arenaActors lid) $ zip arenaFactions entryPoss-      arenaActors _ ((_, Faction{ginitial = 0}), _) = return ()-      arenaActors lid ((side, fact@Faction{ginitial}), ppos) = do+      arenaActors _ ((_, Faction{gplayer = Player{playerInitial = 0}}), _) =+        return ()+      arenaActors lid ((side, fact@Faction{gplayer}), ppos) = do         time <- getsState $ getLocalTime lid-        let ntime = timeAdd time (timeScale timeClip (fromEnum side))+        let nmult = fromEnum side `mod` 5  -- always positive+            ntime = timeAdd time (timeScale timeClip nmult)         psFree <-           getsState $ nearbyFreePoints                         cotile (Tile.hasFeature cotile F.CanActor) ppos lid-        let ps = take ginitial $ zip [0..] psFree+        let ps = take (playerInitial gplayer) $ zip [0..] psFree         forM_ ps $ \ (n, p) ->           if isSpawnFact cops fact           then spawnMonsters [p] lid ((== side) . fst) ntime "spawn"@@ -228,8 +220,7 @@ findEntryPoss :: Kind.COps -> Level -> Int -> Rnd [Point] findEntryPoss Kind.COps{cotile} Level{ltile, lxsize, lysize, lstair} k =   let factionDist = max lxsize lysize - 5-      dist poss cmin l _ =-        all (\pos -> chessDist lxsize l pos > cmin) poss+      dist poss cmin l _ = all (\pos -> chessDist lxsize l pos > cmin) poss       tryFind _ 0 = return []       tryFind ps n = do         np <- findPosTry 40 ltile@@ -243,6 +234,6 @@                 ]         nps <- tryFind (np : ps) (n - 1)         return $ np : nps-      stairPoss | k == 1 = [fst lstair, snd lstair]+      stairPoss | k == 1 = fst lstair ++ snd lstair                 | otherwise = []   in tryFind stairPoss k
Game/LambdaHack/Server/State.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Server and client game state types and operations. module Game.LambdaHack.Server.State   ( StateServer(..), emptyStateServer@@ -10,8 +9,10 @@ import qualified Data.HashMap.Strict as HM import Data.Text (Text) import qualified System.Random as R+import System.Time  import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Perception@@ -29,23 +30,29 @@   , sundo     :: ![Atomic]      -- ^ atomic commands performed to date   , sper      :: !Pers          -- ^ perception of all factions   , srandom   :: !R.StdGen      -- ^ current random generator-  , scenario  :: !Text          -- ^ current game mode   , sconfig   :: Config         -- ^ this game's config (including initial RNG)   , squit     :: !Bool          -- ^ exit the game loop   , sbkpSave  :: !Bool          -- ^ make backup savefile now+  , sstart    :: !ClockTime     -- ^ this session start time   , sdebugSer :: !DebugModeSer  -- ^ current debugging mode   , sdebugNxt :: !DebugModeSer  -- ^ debugging mode for the next game   }   deriving (Show) +-- | Debug commands. See 'Server.debugArgs' for the descriptions. data DebugModeSer = DebugModeSer-  { sknowMap    :: !Bool-  , sknowEvents :: !Bool-  , sniffIn     :: !Bool-  , sniffOut    :: !Bool-  , sallClear   :: !Bool-  , stryFov     :: !(Maybe FovMode)-  , sdebugCli   :: !Bool+  { sknowMap       :: !Bool+  , sknowEvents    :: !Bool+  , sniffIn        :: !Bool+  , sniffOut       :: !Bool+  , sallClear      :: !Bool+  , sgameMode      :: !Text+  , sstopAfter     :: !(Maybe Int)+  , sfovMode       :: !(Maybe FovMode)+  , snewGameSer    :: !Bool+  , ssavePrefixSer :: !(Maybe String)+  , sdbgMsgSer     :: !Bool+  , sdebugCli      :: !DebugModeCli   }   deriving Show @@ -62,10 +69,10 @@     , sundo = []     , sper = EM.empty     , srandom = R.mkStdGen 42-    , scenario = "campaign"     , sconfig = undefined     , squit = False     , sbkpSave = False+    , sstart = TOD 0 0     , sdebugSer = defDebugModeSer     , sdebugNxt = defDebugModeSer     }@@ -76,8 +83,13 @@                                , sniffIn = False                                , sniffOut = False                                , sallClear = False-                               , stryFov = Nothing-                               , sdebugCli = False+                               , sgameMode = "campaign"+                               , sstopAfter = Nothing+                               , sfovMode = Nothing+                               , snewGameSer = False+                               , ssavePrefixSer = Nothing+                               , sdbgMsgSer = False+                               , sdebugCli = defDebugModeCli                                }  instance Binary StateServer where@@ -90,7 +102,6 @@     put sicounter     put sundo     put (show srandom)-    put scenario     put sconfig     put sdebugSer   get = do@@ -102,13 +113,13 @@     sicounter <- get     sundo <- get     g <- get-    scenario <- get     sconfig <- get     sdebugSer <- get     let srandom = read g         sper = EM.empty         squit = False         sbkpSave = False+        sstart = TOD 0 0         sdebugNxt = defDebugModeSer     return StateServer{..} @@ -119,7 +130,11 @@     put sniffIn     put sniffOut     put sallClear-    put stryFov+    put sgameMode+    put sfovMode+    put snewGameSer+    put ssavePrefixSer+    put sdbgMsgSer     put sdebugCli   get = do     sknowMap <- get@@ -127,6 +142,11 @@     sniffIn <- get     sniffOut <- get     sallClear <- get-    stryFov <- get+    sgameMode <- get+    sfovMode <- get+    snewGameSer <- get+    ssavePrefixSer <- get+    sdbgMsgSer <- get     sdebugCli <- get+    let sstopAfter = Nothing     return DebugModeSer{..}
Game/LambdaHack/Utils/Assert.hs view
@@ -2,11 +2,13 @@ -- Actually, a bunch of hacks wrapping the original @assert@ function, -- which is the only easy way of obtaining source positions. module Game.LambdaHack.Utils.Assert-  ( assert, blame, failure, allB, skip+  ( assert, blame, with, failure, allB, skip, forceEither   ) where  import Control.Exception (assert)+import Data.Text (Text) import Debug.Trace (trace)+import qualified Text.Show.Pretty as Show.Pretty  infix 1 `blame` -- | If the condition fails, display the value blamed for the failure.@@ -19,9 +21,13 @@   | condition = True   | otherwise =     let s = "Contract failed and the following is to blame:\n" ++-            "  " ++ show blamed+            "  " ++ Show.Pretty.ppShow blamed     in trace s False +infix 2 `with`+with :: Text -> b -> (Text, b)+with t b = (t, b)+ infix 1 `failure` -- | Like 'error', but shows the source position and also -- the value to blame for the failure. To be used as in:@@ -31,7 +37,7 @@ {-# INLINE failure #-} failure asrt blamed =   let s = "Internal failure occured and the following is to blame:\n" ++-          "  " ++ show blamed+          "  " ++ Show.Pretty.ppShow blamed   in trace s $      asrt False        (error "Assert.failure: no error position (upgrade to GHC >= 7.4)")@@ -43,7 +49,9 @@ allB :: Show a => (a -> Bool) -> [a] -> Bool {-# INLINE allB #-} allB predicate l =-  let s = show (filter (not . predicate) l) ++ " in the context of " ++ show l+  let s = Show.Pretty.ppShow (filter (not . predicate) l)+          ++ " in the context of "+          ++ Show.Pretty.ppShow l   in blame (all predicate l) s  -- | To be used in place of the verbose @skip@, as in:@@ -52,3 +60,8 @@ -- >    assert (b `blame` a) skip skip :: Monad m => m () skip = return ()++-- | In case of corruption, just fail and show the error message.+forceEither :: Show a => Either a b -> b+forceEither (Left a)  = assert `failure` "unexpected Left" `with` a+forceEither (Right b) = b
Game/LambdaHack/Utils/File.hs view
@@ -20,7 +20,7 @@ -- The @OK@ is used as an EOF marker to ensure any apparent problems with -- corrupted files are reported to the user ASAP. encodeEOF :: Binary a => FilePath -> a -> IO ()-encodeEOF f a = encodeData f (a, "OK")+encodeEOF f a = encodeData f (a, "OK" :: String)  -- | Read and decompress the serialized data. strictReadSerialized :: FilePath -> IO LBS.ByteString@@ -40,7 +40,7 @@ strictDecodeEOF :: Binary a => FilePath -> IO a strictDecodeEOF f = do   (a, n) <- strictDecodeData f-  if n == "OK"+  if n == ("OK" :: String)     then return a     else error $ "Fatal error: corrupted file " ++ f @@ -48,8 +48,8 @@ -- with an exception if the directory does not exist, but can't be created. tryCreateDir :: FilePath -> IO () tryCreateDir dir = do-  b <- doesDirectoryExist dir-  unless b $ createDirectory dir+  dirExists <- doesDirectoryExist dir+  unless dirExists $ createDirectory dir  -- | Try to copy over data files, if not already there. tryCopyDataFiles :: (FilePath -> IO FilePath) -> [(FilePath, FilePath)]
Game/LambdaHack/Utils/Frequency.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFoldable, DeriveTraversable #-} -- | A list of items with relative frequencies of appearance. module Game.LambdaHack.Utils.Frequency   ( -- * The @Frequency@ type@@ -13,7 +13,9 @@  import Control.Arrow (first, second) import Control.Monad+import Data.Foldable (Foldable) import Data.Text (Text)+import Data.Traversable (Traversable) import qualified System.Random as R  import Game.LambdaHack.Common.Msg@@ -22,10 +24,10 @@ -- TODO: do not expose runFrequency -- | The frequency distribution type. data Frequency a = Frequency-  { nameFrequency :: Text        -- ^ short description for debug, etc.-  , runFrequency  :: [(Int, a)]  -- ^ give acces to raw frequency values+  { nameFrequency :: !Text        -- ^ short description for debug, etc.+  , runFrequency  :: ![(Int, a)]  -- ^ give acces to raw frequency values   }-  deriving Show+  deriving (Show, Foldable, Traversable)  instance Monad Frequency where   return x = Frequency "return" [(1, x)]@@ -60,7 +62,7 @@ -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a scaleFreq n (Frequency name xs) =-  assert (n > 0 `blame` ("non-positive scale for" <+> name, n, xs)) $+  assert (n > 0 `blame` "non-positive frequency scale" `with` (name, n, xs)) $   Frequency name (map (first (* n)) xs)  -- | Change the description of the frequency.@@ -70,19 +72,19 @@ -- | Randomly choose an item according to the distribution. rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen) rollFreq (Frequency name []) _ =-  assert `failure` ("choice from an empty frequency:" <+> name)+  assert `failure` "choice from an empty frequency" `with` name rollFreq (Frequency name [(n, x)]) _ | n <= 0 =-  assert `failure` ("singleton frequency with nothing to pick:" <+> name, n, x)+  assert `failure` "singleton void frequency" `with` (name, n, x) rollFreq (Frequency _ [(_, x)]) g = (x, g)  -- speedup rollFreq (Frequency name fs) g =-  assert (sumf > 0 `blame` ("frequency with nothing to pick:" <+> name, fs))+  assert (sumf > 0 `blame` "frequency with nothing to pick" `with` (name, fs))     (frec r fs, ng)  where   sumf = sum (map fst fs)   (r, ng) = R.randomR (1, sumf) g   frec :: Int -> [(Int, a)] -> a-  frec m []                     = assert `failure`-                                    ("impossible" <+> name, fs, m)+  frec m []                     = assert `failure` "impossible roll"+                                         `with` (name, fs, m)   frec m ((n, x) : _)  | m <= n = x   frec m ((n, _) : xs)          = frec (m - n) xs
+ Game/LambdaHack/Utils/Thread.hs view
@@ -0,0 +1,29 @@+-- | Keeping track of forked threads.+module Game.LambdaHack.Utils.Thread+  ( forkChild, waitForChildren+  ) where++import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.MVar+import Control.Exception (finally)++-- Swiped from http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html++forkChild :: MVar [MVar ()] -> IO () -> IO ThreadId+forkChild children io = do+  mvar <- newEmptyMVar+  childs <- takeMVar children+  putMVar children (mvar : childs)+  -- @forkFinally@ causes the program not to print client assertion failures+  -- forkFinally io (\_ -> putMVar mvar ())+  forkIO (io `finally` putMVar mvar ())++waitForChildren :: MVar [MVar ()] -> IO ()+waitForChildren children = do+  cs <- takeMVar children+  case cs of+    [] -> return ()+    m : ms -> do+      putMVar children ms+      takeMVar m+      waitForChildren children
LambdaHack.cabal view
@@ -1,5 +1,5 @@ name:          LambdaHack-version:       0.2.8+version:       0.2.10 synopsis:      A roguelike game engine in early and active development description:   This is an alpha release of LambdaHack,                a game engine library for roguelike games@@ -16,15 +16,13 @@                in the strict and type-safe separation of code and content                and of clients (human and AI-controlled) and server.                .-               New, in this release, is cooperative and competitive multiplayer-               (shared-screen only in this version) and overhauled searching.-               The code has been rewritten to have a single server-               that sends restricted game state updates to many-               fat clients, while a thin frontend layer multiplexes-               visuals from a subset of the clients.+               New in this release are screensaver game modes (AI vs AI),+               improved AI (can now climbs stairs, etc.), multiple,+               multi-floor staircases, multiple savefiles, configurable+               framerate and combat animations and more.                Upcoming features: new and improved frontends, improved AI-               (better leader switching and ranged combat), dynamic light-               sources, explosions, player action undo/redo, completely+               (pathfinding, autoexplore, better ranged combat), dynamic+               light sources, explosions, player action undo/redo, completely                redesigned UI. Long term goals are focused on procedural                content generation and include in-game content creation,                auto-balancing and persistent content modification@@ -51,10 +49,11 @@ license-file:  LICENSE tested-with:   GHC == 7.4.2, GHC == 7.6.1 data-files:    LICENSE, CREDITS, PLAYING.md, README.md,-               config.rules.default, config.ui.default, scores+               config.rules.default, config.ui.default, MainMenu.ascii, scores,+               Makefile, .travis.yml author:        Andres Loeh, Mikolaj Konarski maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com>-category:      Game Engine+category:      Game Engine, Game build-type:    Simple cabal-version: >= 1.10 @@ -74,17 +73,12 @@   description:        enable the curses frontend   default:            False -flag std-  description:        enable the stdin/stdout frontend-  default:            False- library   exposed-modules:    Game.LambdaHack.Client,                       Game.LambdaHack.Client.Action,                       Game.LambdaHack.Client.Action.ActionClass,                       Game.LambdaHack.Client.Action.ActionType,                       Game.LambdaHack.Client.Action.ConfigIO,-                      Game.LambdaHack.Client.Action.Save,                       Game.LambdaHack.Client.AtomicSemCli,                       Game.LambdaHack.Client.Binding,                       Game.LambdaHack.Client.ClientSem,@@ -126,6 +120,7 @@                       Game.LambdaHack.Common.Point,                       Game.LambdaHack.Common.PointXY,                       Game.LambdaHack.Common.Random,+                      Game.LambdaHack.Common.Save,                       Game.LambdaHack.Common.ServerCmd,                       Game.LambdaHack.Common.State,                       Game.LambdaHack.Common.Tile,@@ -136,18 +131,18 @@                       Game.LambdaHack.Content.CaveKind,                       Game.LambdaHack.Content.FactionKind,                       Game.LambdaHack.Content.ItemKind,+                      Game.LambdaHack.Content.ModeKind,                       Game.LambdaHack.Content.PlaceKind,                       Game.LambdaHack.Content.RuleKind,-                      Game.LambdaHack.Content.StrategyKind,                       Game.LambdaHack.Content.TileKind,                       Game.LambdaHack.Frontend,                       Game.LambdaHack.Frontend.Chosen,+                      Game.LambdaHack.Frontend.Std,                       Game.LambdaHack.Server,                       Game.LambdaHack.Server.Action,                       Game.LambdaHack.Server.Action.ActionClass,                       Game.LambdaHack.Server.Action.ActionType,                       Game.LambdaHack.Server.Action.ConfigIO,-                      Game.LambdaHack.Server.Action.Save,                       Game.LambdaHack.Server.AtomicSemSer,                       Game.LambdaHack.Server.Config,                       Game.LambdaHack.Server.DungeonGen,@@ -167,7 +162,8 @@                       Game.LambdaHack.Utils.Assert,                       Game.LambdaHack.Utils.File,                       Game.LambdaHack.Utils.Frequency,-                      Game.LambdaHack.Utils.LQueue+                      Game.LambdaHack.Utils.LQueue,+                      Game.LambdaHack.Utils.Thread   other-modules:      Paths_LambdaHack   build-depends:      ConfigFile >= 1.1.1   && < 2,                       array      >= 0.3.0.3 && < 1,@@ -185,6 +181,7 @@                       miniutter  >= 0.4.1   && < 2,                       mtl        >= 2.0.1   && < 3,                       old-time   >= 1.0.0.7 && < 2,+                      pretty-show >= 1.6    && < 2,                       random     >= 1.0.1   && < 2,                       stm        >= 2.4     && < 3,                       text       >= 0.11.2.3 && < 1,@@ -193,12 +190,13 @@                       zlib       >= 0.5.3.1 && < 1    default-language:   Haskell2010-  default-extensions: MonoLocalBinds, ScopedTypeVariables,+  default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings                       BangPatterns, RecordWildCards, NamedFieldPuns-  other-extensions:   CPP, MultiParamTypeClasses, RankNTypes, TypeFamilies,-                      OverloadedStrings, FlexibleContexts, FlexibleInstances,-                      FunctionalDependencies, GeneralizedNewtypeDeriving,-                      DeriveFunctor, TupleSections+  other-extensions:   CPP, TemplateHaskell, MultiParamTypeClasses, RankNTypes,+                      TypeFamilies, FlexibleContexts, FlexibleInstances,+                      DeriveFunctor, FunctionalDependencies,+                      GeneralizedNewtypeDeriving, TupleSections,+                      DeriveFoldable, DeriveTraversable --, DeriveGeneric   ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas   ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude@@ -216,13 +214,10 @@     other-modules:    Game.LambdaHack.Frontend.Curses     build-depends:    hscurses >= 1.4.1 && < 2     cpp-options:      -DCURSES-  } else { if flag(std) {-    other-modules:    Game.LambdaHack.Frontend.Std-    cpp-options:      -DSTD   } else {     other-modules:    Game.LambdaHack.Frontend.Gtk     build-depends:    gtk >= 0.12.1 && < 0.13-  } } } }+  } } }  executable LambdaHack   hs-source-dirs:     LambdaHack@@ -231,11 +226,10 @@                       Content.CaveKind,                       Content.FactionKind,                       Content.ItemKind,+                      Content.ModeKind,                       Content.PlaceKind,                       Content.RuleKind,-                      Content.StrategyKind,                       Content.TileKind,-                      Multiline,                       Paths_LambdaHack   build-depends:      LambdaHack,                       template-haskell >= 2.6 && < 3,@@ -264,24 +258,11 @@                       zlib       >= 0.5.3.1 && < 1    default-language:   Haskell2010-  default-extensions: MonoLocalBinds, ScopedTypeVariables,+  default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings                       BangPatterns, RecordWildCards, NamedFieldPuns-  other-extensions:   CPP, QuasiQuotes, OverloadedStrings+  other-extensions:   CPP, TemplateHaskell   ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas   ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude   ghc-options:        -fno-ignore-asserts -funbox-strict-fields   ghc-options:        -threaded -with-rtsopts=-C0.005 -- ghc-options:       -with-rtsopts=-N  -- eats all cores--executable DumbBot-  hs-source-dirs:     DumbBot-  main-is:            Main.hs-  build-depends:      base       >= 4       && < 5,-                      random     >= 1.0.1   && < 2--  default-language:   Haskell2010-  default-extensions: MonoLocalBinds, ScopedTypeVariables,-                      BangPatterns, RecordWildCards, NamedFieldPuns-  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas-  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude-  ghc-options:        -fno-ignore-asserts -funbox-strict-fields
LambdaHack/Content/ActorKind.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Monsters and heroes for LambdaHack. module Content.ActorKind ( cdefs ) where @@ -25,11 +24,11 @@   , aname   = "hero"   , afreq   = [("hero", 1)]   , acolor  = BrWhite  -- modified if many hero factions-  , ahp     = RollDice 50 1+  , ahp     = rollDice 50 1   , aspeed  = toSpeed 2   , asight  = True   , asmell  = False-  , aiq     = 16+  , aiq     = 15  -- higher that that leads to looping movement   , aregen  = 500   , acanDo  = [minBound..maxBound]   }@@ -39,7 +38,7 @@   , aname   = "projectile"   , afreq   = [("projectile", 1)]  -- Does not appear randomly in the dungeon.   , acolor  = BrWhite-  , ahp     = RollDice 0 0+  , ahp     = rollDice 0 0   , aspeed  = toSpeed 0   , asight  = False   , asmell  = False@@ -53,7 +52,7 @@   , aname   = "reducible eye"   , afreq   = [("monster", 60), ("horror", 60)]   , acolor  = BrRed-  , ahp     = RollDice 7 4+  , ahp     = rollDice 7 4   , aspeed  = toSpeed 2   , asight  = True   , asmell  = False@@ -66,7 +65,7 @@   , aname   = "super-fast eye"   , afreq   = [("monster", 15), ("horror", 15)]   , acolor  = BrBlue-  , ahp     = RollDice 1 4+  , ahp     = rollDice 1 4   , aspeed  = toSpeed 4   , asight  = True   , asmell  = False@@ -79,7 +78,7 @@   , aname   = "point-free nose"   , afreq   = [("monster", 20), ("horror", 20)]   , acolor  = Green-  , ahp     = RollDice 17 2+  , ahp     = rollDice 17 2   , aspeed  = toSpeed 1.8   , asight  = False   , asmell  = True
LambdaHack/Content/CaveKind.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Cave layouts for LambdaHack. module Content.CaveKind ( cdefs ) where @@ -26,9 +25,9 @@   , cfreq         = [("dng", 100), ("caveRogue", 1)]   , cxsize        = fst normalLevelBound + 1   , cysize        = snd normalLevelBound + 1-  , cgrid         = RollDiceXY (RollDice 2 3, RollDice 2 2)-  , cminPlaceSize = RollDiceXY (RollDice 2 2, RollDice 2 1)-  , cdarkChance   = (RollDice 1 54, RollDice 0 0)+  , cgrid         = RollDiceXY (rollDice 2 3, rollDice 2 2)+  , cminPlaceSize = RollDiceXY (rollDice 2 2, rollDice 2 1)+  , cdarkChance   = (rollDice 1 54, rollDice 0 0)   , cauxConnects  = 1%3   , cvoidChance   = 1%4   , cnonVoidMin   = 4@@ -36,7 +35,7 @@   , cdoorChance   = 1%2   , copenChance   = 1%10   , chidden       = 8-  , citemNum      = RollDice 7 2+  , citemNum      = rollDice 7 2   , cdefTile        = "fillerWall"   , ccorridorTile   = "darkCorridor"   , cfillerTile     = "fillerWall"@@ -47,13 +46,13 @@   { csymbol       = 'A'   , cname         = "Underground city"   , cfreq         = [("dng", 30), ("caveArena", 1)]-  , cgrid         = RollDiceXY (RollDice 2 2, RollDice 2 2)-  , cminPlaceSize = RollDiceXY (RollDice 3 2, RollDice 2 1)-  , cdarkChance   = (RollDice 1 80, RollDice 1 60)+  , cgrid         = RollDiceXY (rollDice 2 2, rollDice 2 2)+  , cminPlaceSize = RollDiceXY (rollDice 3 2, rollDice 2 1)+  , cdarkChance   = (rollDice 1 80, rollDice 1 60)   , cvoidChance   = 1%3   , cnonVoidMin   = 2   , chidden       = 9-  , citemNum      = RollDice 4 2  -- few rooms+  , citemNum      = rollDice 4 2  -- few rooms   , cdefTile      = "floorArenaLit"   , ccorridorTile = "path"   }@@ -61,15 +60,15 @@   { csymbol       = '.'   , cname         = "Tall cavern"   , cfreq         = [("dng", 20), ("caveEmpty", 1)]-  , cgrid         = RollDiceXY (RollDice 2 2, RollDice 1 2)-  , cminPlaceSize = RollDiceXY (RollDice 4 3, RollDice 4 1)-  , cdarkChance   = (RollDice 1 80, RollDice 1 80)+  , cgrid         = RollDiceXY (rollDice 2 2, rollDice 1 2)+  , cminPlaceSize = RollDiceXY (rollDice 4 3, rollDice 4 1)+  , cdarkChance   = (rollDice 1 80, rollDice 1 80)   , cauxConnects  = 1   , cvoidChance   = 3%4   , cnonVoidMin   = 1   , cminStairDist = 50   , chidden       = 10-  , citemNum      = RollDice 8 2  -- whole floor strewn with treasure+  , citemNum      = rollDice 8 2  -- whole floor strewn with treasure   , cdefTile      = "floorRoomLit"   , ccorridorTile = "floorRoomLit"   }@@ -77,13 +76,13 @@   { csymbol       = '!'   , cname         = "Glittering cave"   , cfreq         = [("dng", 20), ("caveNoise", 1)]-  , cgrid         = RollDiceXY (RollDice 2 2, RollDice 1 2)-  , cminPlaceSize = RollDiceXY (RollDice 4 2, RollDice 4 1)-  , cdarkChance   = (RollDice 1 80, RollDice 1 40)+  , cgrid         = RollDiceXY (rollDice 2 2, rollDice 1 2)+  , cminPlaceSize = RollDiceXY (rollDice 4 2, rollDice 4 1)+  , cdarkChance   = (rollDice 1 80, rollDice 1 40)   , cvoidChance   = 0   , cnonVoidMin   = 0   , chidden       = 6-  , citemNum      = RollDice 4 2  -- few rooms+  , citemNum      = rollDice 4 2  -- few rooms   , cdefTile      = "noiseSet"   , ccorridorTile = "path"   }@@ -91,13 +90,13 @@   { csymbol       = 'C'   , cname         = "Combat arena"   , cfreq         = [("caveCombat", 1)]-  , cgrid         = RollDiceXY (RollDice 5 2, RollDice 2 2)-  , cminPlaceSize = RollDiceXY (RollDice 1 1, RollDice 1 1)-  , cdarkChance   = (RollDice 1 100, RollDice 1 100)+  , cgrid         = RollDiceXY (rollDice 5 2, rollDice 2 2)+  , cminPlaceSize = RollDiceXY (rollDice 1 1, rollDice 1 1)+  , cdarkChance   = (rollDice 1 100, rollDice 1 100)   , cvoidChance   = 1%10   , cnonVoidMin   = 8   , chidden       = 100-  , citemNum      = RollDice 12 2+  , citemNum      = rollDice 12 2   , cdefTile      = "combatSet"   , ccorridorTile = "path"   }
LambdaHack/Content/FactionKind.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE OverloadedStrings #-} -- | The type of kinds of game factions (heroes, enemies, NPCs, etc.) -- for LambdaHack. module Content.FactionKind ( cdefs ) where +import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Content.FactionKind @@ -18,25 +18,38 @@ hero,        monster, horror :: FactionKind  hero = FactionKind-  { fsymbol   = '@'-  , fname     = "hero"-  , ffreq     = [("hero", 1)]-  , fAiLeader = "fullAbility"-  , fAiMember = "meleeAdjacent"+  { fsymbol        = '@'+  , fname          = "hero"+  , ffreq          = [("hero", 1)]+  , fAbilityLeader = allAbilities+  , fAbilityOther  = meleeAdjacent   }  monster = FactionKind-  { fsymbol   = 'm'-  , fname     = "monster"-  , ffreq     = [("monster", 1), ("spawn", 50), ("summon", 50)]-  , fAiLeader = "fullAbility"-  , fAiMember = "fullAbility"+  { fsymbol        = 'm'+  , fname          = "monster"+  , ffreq          = [("monster", 1), ("spawn", 50), ("summon", 50)]+  , fAbilityLeader = allAbilities+  , fAbilityOther  = allAbilities   }  horror = FactionKind-  { fsymbol   = 'h'-  , fname     = "horror"-  , ffreq     = [("horror", 1), ("summon", 50)]-  , fAiLeader = "fullAbility"-  , fAiMember = "fullAbility"+  { fsymbol        = 'h'+  , fname          = "horror"+  , ffreq          = [("horror", 1), ("summon", 50)]+  , fAbilityLeader = allAbilities+  , fAbilityOther  = allAbilities   }+++_noAbility, _onlyFollowTrack, meleeAdjacent, _meleeAndRanged, allAbilities :: [Ability]++_noAbility = []  -- not even projectiles will fly++_onlyFollowTrack = [Track]  -- projectiles enabled++meleeAdjacent = [Track, Melee]++_meleeAndRanged = [Track, Melee, Ranged]  -- melee and reaction fire++allAbilities = [minBound..maxBound]
LambdaHack/Content/ItemKind.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Weapons and treasure for LambdaHack. module Content.ItemKind ( cdefs ) where @@ -22,14 +21,14 @@  gem, potion, scroll, wand :: ItemKind  -- generic templates --- rollDeep (aDb, xDy) = rollDice aDb + lvl * rollDice xDy / depth+-- castDeep (aDb, xDy) = castDice aDb + lvl * castDice xDy / depth  amulet = ItemKind   { isymbol  = '"'   , iname    = "amulet"   , ifreq    = [("dng", 6)]   , iflavour = zipFancy [BrGreen]-  , ieffect  = Regeneration (RollDice 2 3, RollDice 1 10)+  , ieffect  = Regeneration (rollDice 2 3, rollDice 1 10)   , icount   = intToDeep 1   , iverbApply   = "tear down"   , iverbProject = "cast"@@ -41,8 +40,8 @@   , iname    = "dart"   , ifreq    = [("dng", 30)]   , iflavour = zipPlain [Cyan]-  , ieffect  = Hurt (RollDice 1 1) (RollDice 1 2, RollDice 1 2)-  , icount   = (RollDice 3 3, RollDice 0 0)+  , ieffect  = Hurt (rollDice 1 1) (rollDice 1 2, rollDice 1 2)+  , icount   = (rollDice 3 3, rollDice 0 0)   , iverbApply   = "snap"   , iverbProject = "hurl"   , iweight  = 50@@ -61,13 +60,13 @@   , itoThrow = 0   } gem1 = gem-  { icount   = (RollDice 0 0, RollDice 1 1)  -- appears on lvl 1+  { icount   = (rollDice 0 0, rollDice 1 1)  -- appears on lvl 1   } gem2 = gem-  { icount   = (RollDice 0 0, RollDice 1 2)  -- appears halfway+  { icount   = (rollDice 0 0, rollDice 1 2)  -- appears halfway   } gem3 = gem-  { icount   = (RollDice 0 0, RollDice 1 3)  -- appears on max depth+  { icount   = (rollDice 0 0, rollDice 1 3)  -- appears on max depth   } currency = ItemKind   { isymbol  = '$'@@ -75,7 +74,7 @@   , ifreq    = [("dng", 50), ("currency", 1)]   , iflavour = zipPlain [BrYellow]   , ieffect  = NoEffect-  , icount   = (RollDice 0 0, RollDice 10 10)+  , icount   = (rollDice 0 0, rollDice 10 10)   , iverbApply   = "grind"   , iverbProject = "toss"   , iweight  = 31@@ -86,8 +85,8 @@   , iname    = "harpoon"   , ifreq    = [("dng", 30)]   , iflavour = zipPlain [Brown]-  , ieffect  = Hurt (RollDice 1 2) (RollDice 1 2, RollDice 2 2)-  , icount   = (RollDice 0 0, RollDice 2 2)+  , ieffect  = Hurt (rollDice 1 2) (rollDice 1 2, rollDice 2 2)+  , icount   = (rollDice 0 0, rollDice 2 2)   , iverbApply   = "break up"   , iverbProject = "hurl"   , iweight  = 4000@@ -121,7 +120,7 @@   , iname    = "ring"   , ifreq    = []  -- [("dng", 10)]  -- TODO: make it useful   , iflavour = zipPlain [White]-  , ieffect  = Searching (RollDice 1 6, RollDice 3 2)+  , ieffect  = Searching (rollDice 1 6, rollDice 3 2)   , icount   = intToDeep 1   , iverbApply   = "squeeze down"   , iverbProject = "toss"@@ -148,14 +147,14 @@   { ieffect  = Summon 1   } scroll3 = scroll-  { ieffect  = Descend 1+  { ieffect  = Ascend (-1)   } sword = ItemKind   { isymbol  = ')'   , iname    = "sword"   , ifreq    = [("dng", 40)]   , iflavour = zipPlain [BrCyan]-  , ieffect  = Hurt (RollDice 3 1) (RollDice 1 2, RollDice 4 2)+  , ieffect  = Hurt (rollDice 3 1) (rollDice 1 2, rollDice 4 2)   , icount   = intToDeep 1   , iverbApply   = "hit"   , iverbProject = "heave"@@ -185,7 +184,7 @@   { isymbol  = '@'   , iname    = "fist"   , ifreq    = [("hth", 1), ("unarmed", 100)]-  , ieffect  = Hurt (RollDice 3 1) (intToDeep 0)+  , ieffect  = Hurt (rollDice 3 1) (intToDeep 0)   , iverbApply   = "punch"   , iverbProject = "ERROR, please report: iverbProject fist"   }@@ -193,7 +192,7 @@   { isymbol  = '@'   , iname    = "foot"   , ifreq    = [("hth", 1), ("unarmed", 50)]-  , ieffect  = Hurt (RollDice 3 1) (intToDeep 0)+  , ieffect  = Hurt (rollDice 3 1) (intToDeep 0)   , iverbApply   = "kick"   , iverbProject = "ERROR, please report: iverbProject foot"   }@@ -201,7 +200,7 @@   { isymbol  = 'S'   , iname    = "tentacle"   , ifreq    = [("hth", 1), ("monstrous", 100)]-  , ieffect  = Hurt (RollDice 3 1) (intToDeep 0)+  , ieffect  = Hurt (rollDice 3 1) (intToDeep 0)   , iverbApply   = "hit"   , iverbProject = "ERROR, please report: iverbProject tentacle"   }
+ LambdaHack/Content/ModeKind.hs view
@@ -0,0 +1,259 @@+-- | The type of kinds of game modes for LambdaHack.+module Content.ModeKind ( cdefs ) where++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Content.ModeKind++cdefs :: ContentDef ModeKind+cdefs = ContentDef+  { getSymbol = msymbol+  , getName = mname+  , getFreq = mfreq+  , validate = mvalidate+  , content =+      [campaign, skirmish, pvp, coop, defense, screensaver, testCoop, testDefense, peekCampaign, peekSkirmish]+  }+campaign,        skirmish, pvp, coop, defense, screensaver, testCoop, testDefense, peekCampaign, peekSkirmish :: ModeKind++campaign = ModeKind+  { msymbol  = 'r'+  , mname    = "campaign"+  , mfreq    = [("campaign", 1)]+  , mplayers = playersCampaign+  , mcaves   = cavesCampaign+  }++skirmish = ModeKind+  { msymbol  = 's'+  , mname    = "skirmish"+  , mfreq    = [("skirmish", 1)]+  , mplayers = playersSkirmish+  , mcaves   = cavesCombat+  }++pvp = ModeKind+  { msymbol  = 'p'+  , mname    = "PvP"+  , mfreq    = [("PvP", 1)]+  , mplayers = playersPvP+  , mcaves   = cavesCombat+  }++coop = ModeKind+  { msymbol  = 'c'+  , mname    = "Coop"+  , mfreq    = [("Coop", 1)]+  , mplayers = playersCoop+  , mcaves   = cavesCampaign+  }++defense = ModeKind+  { msymbol  = 'd'+  , mname    = "defense"+  , mfreq    = [("defense", 1)]+  , mplayers = playersDefense+  , mcaves   = cavesDefense+  }++screensaver = ModeKind+  { msymbol  = 'n'+  , mname    = "screensaver"+  , mfreq    = [("screensaver", 1)]+  , mplayers = playersScreensaver+  , mcaves   = cavesScreensaver+  }++testCoop = ModeKind+  { msymbol  = 't'+  , mname    = "testCoop"+  , mfreq    = [("testCoop", 1)]+  , mplayers = playersTestCoop+  , mcaves   = cavesScreensaver+  }++testDefense = ModeKind+  { msymbol  = 'u'+  , mname    = "testDefense"+  , mfreq    = [("testDefense", 1)]+  , mplayers = playersTestDefense+  , mcaves   = cavesDefense+  }++peekCampaign = ModeKind+  { msymbol  = 'e'+  , mname    = "peekCampaign"+  , mfreq    = [("peekCampaign", 1)]+  , mplayers = playersPeekCampaign+  , mcaves   = cavesCampaign+  }++peekSkirmish = ModeKind+  { msymbol  = 'f'+  , mname    = "peekSkirmish"+  , mfreq    = [("peekSkirmish", 1)]+  , mplayers = playersPeekSkirmish+  , mcaves   = cavesCombat+  }+++playersCampaign, playersSkirmish, playersPvP, playersCoop, playersDefense, playersScreensaver, playersTestCoop, playersTestDefense, playersPeekCampaign, playersPeekSkirmish :: Players++playersCampaign = Players+  { playersList = [ playerHero {playerInitial = 1}+                  , playerMonster ]+  , playersEnemy = [("Adventuring Party", "Monster Hive")]+  , playersAlly = [] }++playersSkirmish = Players+  { playersList = [ playerHero {playerName = "White"}+                  , playerAntiHero {playerName = "Green"}+                  , playerHorror ]+  , playersEnemy = [ ("White", "Green")+                   , ("White", "Horror Den")+                   , ("Green", "Horror Den") ]+  , playersAlly = [] }++playersPvP = Players+  { playersList = [ playerHero {playerName = "Red"}+                  , playerHero {playerName = "Blue"}+                  , playerHorror ]+  , playersEnemy = [ ("Red", "Blue")+                   , ("Red", "Horror Den")+                   , ("Blue", "Horror Den") ]+  , playersAlly = [] }++playersCoop = Players+  { playersList = [ playerHero { playerName = "Coral"+                               , playerInitial = 1 }+                  , playerHero { playerName = "Amber"+                               , playerInitial = 1 }+                  , playerMonster ]+  , playersEnemy = [ ("Coral", "Monster Hive")+                   , ("Amber", "Monster Hive") ]+  , playersAlly = [("Coral", "Amber")] }++playersDefense = Players+  { playersList = [ playerMonster { playerInitial = 1+                                  , playerEntry = toEnum (-1)+                                  , playerAiLeader = False+                                  , playerHuman = True+                                  , playerUI = True }+                  , playerAntiHero {playerName = "Green"}+                  , playerAntiHero {playerName = "Yellow"}+                  , playerAntiHero {playerName = "Cyan"} ]+  , playersEnemy = [ ("Green", "Monster Hive")+                   , ("Yellow", "Monster Hive")+                   , ("Cyan", "Monster Hive") ]+  , playersAlly = [ ("Green", "Yellow")+                  , ("Green", "Cyan")+                  , ("Yellow", "Cyan") ] }++playersScreensaver = Players+  { playersList = [ playerHero { playerInitial = 5+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerMonster ]+  , playersEnemy = [("Adventuring Party", "Monster Hive")]+  , playersAlly = [] }++playersTestCoop = Players+  { playersList = [ playerHero { playerName = "Coral"+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerHero { playerName = "Amber"+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerMonster ]+  , playersEnemy = [ ("Coral", "Monster Hive")+                   , ("Amber", "Monster Hive") ]+  , playersAlly = [("Coral", "Amber")] }++playersTestDefense = Players+  { playersList = [ playerMonster { playerInitial = 1+                                  , playerEntry = toEnum (-1)+                                  , playerUI = True }+                  , playerAntiHero {playerName = "Green"}+                  , playerAntiHero {playerName = "Yellow"}+                  , playerAntiHero {playerName = "Cyan"} ]+  , playersEnemy = [ ("Green", "Monster Hive")+                   , ("Yellow", "Monster Hive")+                   , ("Cyan", "Monster Hive") ]+  , playersAlly = [ ("Green", "Yellow")+                  , ("Green", "Cyan")+                  , ("Yellow", "Cyan") ] }++playersPeekCampaign = Players+  { playersList = [ playerHero {playerInitial = 1}+                  , playerMonster {playerUI = True} ]+  , playersEnemy = [("Adventuring Party", "Monster Hive")]+  , playersAlly = [] }++playersPeekSkirmish = Players+  { playersList = [ playerHero {playerName = "White"}+                  , playerAntiHero { playerName = "Green"+                                   , playerUI = True }+                  , playerHorror ]+  , playersEnemy = [ ("White", "Green")+                   , ("White", "Horror Den")+                   , ("Green", "Horror Den") ]+  , playersAlly = [] }+++playerHero, playerAntiHero, playerMonster, playerHorror :: Player++playerHero = Player+  { playerName = "Adventuring Party"+  , playerFaction = "hero"+  , playerEntry = toEnum (-1)+  , playerInitial = 3+  , playerAiLeader = False+  , playerAiOther = True+  , playerHuman = True+  , playerUI = True+  }++playerAntiHero = playerHero+  { playerAiLeader = True+  , playerHuman = False+  , playerUI = False+  }++playerMonster = Player+  { playerName = "Monster Hive"+  , playerFaction = "monster"+  , playerEntry = toEnum (-3)+  , playerInitial = 5+  , playerAiLeader = True+  , playerAiOther = True+  , playerHuman = False+  , playerUI = False+  }++playerHorror = Player+  { playerName = "Horror Den"+  , playerFaction = "horror"+  , playerEntry = toEnum (-1)+  , playerInitial = 0+  , playerAiLeader = True+  , playerAiOther = True+  , playerHuman = False+  , playerUI = False+  }+++cavesCampaign, cavesCombat, cavesDefense, cavesScreensaver :: Caves++cavesCampaign = EM.fromList [ (toEnum (-1), ("caveRogue", Just True))+                            , (toEnum (-2), ("caveRogue", Nothing))+                            , (toEnum (-3), ("caveEmpty", Nothing))+                            , (toEnum (-10), ("caveNoise", Nothing))]++cavesCombat = EM.fromList [(toEnum (-3), ("caveCombat", Nothing))]++cavesDefense = EM.fromList [ (toEnum (-1), ("dng", Nothing))+                           , (toEnum (-5), ("caveEmpty", Just False))]++cavesScreensaver = EM.fromList [ (toEnum (-1), ("caveRogue", Nothing))+                               , (toEnum (-10), ("caveNoise", Just False))]
LambdaHack/Content/PlaceKind.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE OverloadedStrings #-} -- | Rooms, halls and passages for LambdaHack. module Content.PlaceKind ( cdefs ) where -import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Content.PlaceKind  cdefs :: ContentDef PlaceKind cdefs = ContentDef@@ -48,9 +47,9 @@                ]   } pillar3 = pillar-  { pfreq    = [("rogue", 100)]  -- Feels a bit intrusive with so many pillars.+  { pfreq    = [("rogue", 200)]   , ptopLeft = [ "-----"-               , "|O.O."+               , "|&.O."                , "|...."                , "|O..."                , "|...."
LambdaHack/Content/RuleKind.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE CPP, OverloadedStrings, QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-} -- | Game rules and assorted game setup data for LambdaHack. module Content.RuleKind ( cdefs ) where +import Language.Haskell.TH.Syntax+ -- Cabal import qualified Paths_LambdaHack as Self (getDataFileName, version) @@ -10,7 +12,6 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind-import Multiline  cdefs :: ContentDef RuleKind cdefs = ContentDef@@ -32,14 +33,18 @@   -- Apart of checking the target tile, we forbid diagonal movement   -- to and from doors.   , raccessible    = \ lxsize spos src tpos tgt ->-      F.Walkable `elem` tfeature tgt-      && not ((F.Closable `elem` tfeature src ||-               F.Closable `elem` tfeature tgt)-              && diagonal lxsize (displacement spos tpos))+      let getTo F.CloseTo{} = True+          getTo _ = False+      in F.Walkable `elem` tfeature tgt+         && not ((any getTo (tfeature  src) ||+                  any getTo (tfeature tgt))+                 && diagonal lxsize (displacement spos tpos))   , rtitle         = "LambdaHack"   , rpathsDataFile = Self.getDataFileName   , rpathsVersion  = Self.version   , ritemMelee     = ")"+  , ritemRanged    = "|"+  -- Wasting weapons and armour would be too cruel to the player.   , ritemProject   = "!?|/"   -- The strings containing the default configuration files,   -- included from files config.game.default and config.ui.default.@@ -47,52 +52,31 @@   -- so touching them is needed to reinclude configs and recompile.   -- Note: consider code.haskell.org/~dons/code/compiled-constants   -- as soon as the config file grows very big.-  , rcfgRulesDefault = [multiline|-#include "../../config.rules.default"-|]-  , rcfgUIDefault = [multiline|-#include "../../config.ui.default"-|]+  , rcfgRulesDefault = $(do+      qAddDependentFile "config.rules.default"+      x <- qRunIO (readFile "config.rules.default")+      lift x)+  , rcfgUIDefault = $(do+      qAddDependentFile "config.ui.default"+      x <- qRunIO (readFile "config.ui.default")+      lift x)   -- ASCII art for the Main Menu. Only pure 7-bit ASCII characters are   -- allowed. The picture should be exactly 24 rows by 80 columns,-  -- plus an extra frame of any charecters that is ignored for all purposes.+  -- plus an extra frame (of any characters) that is ignored.   -- For a different screen size, the picture is centered and the outermost   -- rows and columns cloned. When displayed in the Main Menu screen,   -- it's overwritten with the game version string and keybinding strings.   -- The game version string begins and ends with a space and is placed   -- in the very bottom right corner. The keybindings overwrite places   -- marked with 25 left curly brace signs '{' in a row. The sign is forbidden-  -- everywhere else. Exactly five such places with 25 left braces+  -- everywhere else. A specific number of such places with 25 left braces   -- are required, at most one per row, and all are overwritten   -- with text that is flushed left and padded with spaces.   -- The Main Menu is displayed dull white on black.-  -- TODO: Highlighted keybinding is in inverse video or bright white on grey+  -- TODO: Show highlighted keybinding in inverse video or bright white on grey   -- background. The spaces that pad keybindings are not highlighted.-  , rmainMenuArt = [multiline|------------------------------------------------------------------------------------|                                                                                |-|                      >> LambdaHack <<                                          |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                                                                                |-|                                                                                |-|                        Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) |------------------------------------------------------------------------------------|]}+  , rmainMenuArt = $(do+      qAddDependentFile "MainMenu.ascii"+      x <- qRunIO (readFile "MainMenu.ascii")+      lift x)+  }
− LambdaHack/Content/StrategyKind.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | AI strategies for LambdaHack.-module Content.StrategyKind ( cdefs ) where--import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Content.StrategyKind--cdefs :: ContentDef StrategyKind-cdefs = ContentDef-  { getSymbol = ssymbol-  , getName = sname-  , getFreq = sfreq-  , validate = svalidate-  , content =-      [noAbility, onlyFollowTrack, meleeAdjacent, meleeAndRanged, fullAbility]-  }-noAbility,        onlyFollowTrack, meleeAdjacent, meleeAndRanged, fullAbility :: StrategyKind--noAbility = StrategyKind  -- not even projectiles will fly-  { ssymbol    = '@'-  , sname      = "noAbility"-  , sfreq      = [("noAbility", 1)]-  , sabilities = []-  }--onlyFollowTrack = StrategyKind  -- projectiles enabled-  { ssymbol    = '@'-  , sname      = "onlyFollowTrack"-  , sfreq      = [("onlyFollowTrack", 1)]-  , sabilities = [Track]-  }--meleeAdjacent = StrategyKind-  { ssymbol    = '@'-  , sname      = "meleeAdjacent"-  , sfreq      = [("meleeAdjacent", 1)]-  , sabilities = [Track, Melee]-  }--meleeAndRanged = StrategyKind  -- melee and reaction fire-  { ssymbol    = '@'-  , sname      = "meleeAndRanged"-  , sfreq      = [("meleeAndRanged", 1)]-  , sabilities = [Track, Melee, Ranged]-  }--fullAbility = StrategyKind-  { ssymbol    = '@'-  , sname      = "fullAbility"-  , sfreq      = [("fullAbility", 1)]-  , sabilities = [minBound..maxBound]-  }
LambdaHack/Content/TileKind.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE OverloadedStrings #-} -- | Terrain tiles for LambdaHack. module Content.TileKind ( cdefs ) where @@ -15,14 +14,14 @@   , getFreq = tfreq   , validate = tvalidate   , content =-      [wall, hardRock, pillar, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRed, floorBlue, floorGreen, floorBrown]+      [wall, hardRock, pillar, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, pillarCache, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRed, floorBlue, floorGreen, floorBrown]   }-wall,        hardRock, pillar, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRed, floorBlue, floorGreen, floorBrown :: TileKind+wall,        hardRock, pillar, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, pillarCache, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRed, floorBlue, floorGreen, floorBrown :: TileKind  wall = TileKind   { tsymbol  = ' '   , tname    = "rock"-  , tfreq    = [("litLegend", 100), ("darkLegend", 100), ("fillerWall", 1)]+  , tfreq    = [("fillerWall", 1), ("litLegend", 100), ("darkLegend", 100)]   , tcolor   = BrWhite   , tcolor2  = defFG   , tfeature = []@@ -38,19 +37,29 @@ pillar = TileKind   { tsymbol  = 'O'   , tname    = "pillar"-  , tfreq    = [ ("litLegend", 100), ("darkLegend", 100)+  , tfreq    = [ ("cachable", 70)+               , ("litLegend", 100), ("darkLegend", 100)                , ("noiseSet", 55), ("combatSet", 5) ]   , tcolor   = BrWhite   , tcolor2  = defFG   , tfeature = []   }+pillarCache = TileKind+  { tsymbol  = '&'+  , tname    = "wall cache"+  , tfreq    = [ ("cachable", 30)+               , ("litLegend", 100), ("darkLegend", 100) ]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Cause $ Effect.CreateItem 1, ChangeTo "cachable"]+  } wallV = TileKind   { tsymbol  = '|'   , tname    = "granite wall"   , tfreq    = [("litLegend", 100), ("darkLegend", 100)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [HiddenAs "suspect vertical wall"]+  , tfeature = [HideAs "suspect vertical wall"]   } wallSuspectV = TileKind   { tsymbol  = '|'@@ -59,7 +68,7 @@   , tcolor   = BrWhite   , tcolor2  = defFG   , tfeature = [ Suspect-               , ChangeTo "vertical closed door"  -- never triggered, hack 47+               , RevealAs "vertical closed door"                ]   } doorClosedV = TileKind@@ -68,9 +77,9 @@   , tfreq    = [("vertical closed door", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Exit, Openable-               , ChangeTo "vertical open door"-               , HiddenAs "suspect vertical wall"+  , tfeature = [ Exit+               , OpenTo "vertical open door"+               , HideAs "suspect vertical wall"                ]   } doorOpenV = TileKind@@ -79,8 +88,8 @@   , tfreq    = [("vertical open door", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, Exit, Closable-               , ChangeTo "vertical closed door"+  , tfeature = [ Walkable, Clear, Exit+               , CloseTo "vertical closed door"                ]   } wallH = TileKind@@ -89,7 +98,7 @@   , tfreq    = [("litLegend", 100), ("darkLegend", 100)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [HiddenAs "suspect horizontal wall"]+  , tfeature = [HideAs "suspect horizontal wall"]   } wallSuspectH = TileKind   { tsymbol  = '-'@@ -98,7 +107,7 @@   , tcolor   = BrWhite   , tcolor2  = defFG   , tfeature = [ Suspect-               , ChangeTo "horizontal closed door"  -- never triggered, hack 47+               , RevealAs "horizontal closed door"                ]   } doorClosedH = TileKind@@ -107,9 +116,9 @@   , tfreq    = [("horizontal closed door", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Exit, Openable-               , ChangeTo "horizontal open door"-               , HiddenAs "suspect horizontal wall"+  , tfeature = [ Exit+               , OpenTo "horizontal open door"+               , HideAs "suspect horizontal wall"                ]   } doorOpenH = TileKind@@ -118,8 +127,8 @@   , tfreq    = [("horizontal open door", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, Exit, Closable-               , ChangeTo "horizontal closed door"+  , tfeature = [ Walkable, Clear, Exit+               , CloseTo "horizontal closed door"                ]   } stairsUpDark = TileKind@@ -131,7 +140,7 @@ -- Dark room interior, OTOH, is fine:   , tcolor   = BrWhite   , tcolor2  = BrBlack-  , tfeature = [Walkable, Clear, Exit, Ascendable, Cause $ Effect.Ascend 1]+  , tfeature = [Walkable, Clear, Exit, Cause $ Effect.Ascend 1]   } stairsUpLit = stairsUpDark   { tfreq    = [("litLegend", 100)]@@ -139,16 +148,29 @@   , tcolor2  = defFG   , tfeature = Lit : tfeature stairsUpDark   }+stairsDark = TileKind+  { tsymbol  = '>'+  , tname    = "staircase"+  , tfreq    = [("darkLegend", 100)]+  , tcolor   = BrCyan+  , tcolor2  = Cyan  -- TODO+  , tfeature = [ Walkable, Clear, Exit+               , Cause $ Effect.Ascend 1+               , Cause $ Effect.Ascend (-1) ]+  }+stairsLit = stairsDark+  { tfreq    = [("litLegend", 100)]+  , tcolor   = BrCyan+  , tcolor2  = Cyan  -- TODO+  , tfeature = Lit : tfeature stairsDark+  } stairsDownDark = TileKind   { tsymbol  = '>'   , tname    = "staircase down"   , tfreq    = [("darkLegend", 100)]--- Disabled, because the yellow artificial light does not fit LambdaHack.---  , tcolor   = BrYellow--- Dark room interior, OTOH, is fine:   , tcolor   = BrWhite   , tcolor2  = BrBlack-  , tfeature = [Walkable, Clear, Exit, Descendable, Cause $ Effect.Descend 1]+  , tfeature = [Walkable, Clear, Exit, Cause $ Effect.Ascend (-1)]   } stairsDownLit = stairsDownDark   { tfreq    = [("litLegend", 100)]@@ -167,6 +189,18 @@ escapeUpLit = escapeUpDark   { tfreq    = [("litLegend", 100)]   , tfeature = Lit : tfeature escapeUpDark+  }+escapeDownDark = TileKind+  { tsymbol  = '>'+  , tname    = "exit trapdoor down"+  , tfreq    = [("darkLegend", 100)]+  , tcolor   = BrYellow+  , tcolor2  = BrYellow+  , tfeature = [Walkable, Clear, Exit, Cause Effect.Escape]+  }+escapeDownLit = escapeDownDark+  { tfreq    = [("litLegend", 100)]+  , tfeature = Lit : tfeature escapeDownDark   } unknown = TileKind   { tsymbol  = ' '
LambdaHack/Main.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}--- | The main code file of LambdaHack. Here the knot of engine+-- | The main source code file of LambdaHack. Here the knot of engine -- code pieces and the LambdaHack-specific content defintions is tied, -- resulting in an executable game. module Main ( main ) where@@ -8,9 +8,9 @@ import qualified Content.CaveKind import qualified Content.FactionKind import qualified Content.ItemKind+import qualified Content.ModeKind import qualified Content.PlaceKind import qualified Content.RuleKind-import qualified Content.StrategyKind import qualified Content.TileKind import Game.LambdaHack.Client import Game.LambdaHack.Client.Action.ActionType@@ -25,10 +25,12 @@ instance MonadAtomic ActionSer where   execAtomic = atomicSendSem -instance MonadAtomic (ActionCli c) where+instance MonadAtomic (ActionCli c d) where   execAtomic (CmdAtomic cmd) = cmdAtomicSem cmd   execAtomic (SfxAtomic _) = return () +-- | Tie the LambdaHack engine clients and server code+-- with the LambdaHack-specific content defintions and run the game. main :: IO () main =   let copsSlow = Kind.COps@@ -36,9 +38,9 @@         , cocave  = Kind.createOps Content.CaveKind.cdefs         , cofact  = Kind.createOps Content.FactionKind.cdefs         , coitem  = Kind.createOps Content.ItemKind.cdefs+        , comode  = Kind.createOps Content.ModeKind.cdefs         , coplace = Kind.createOps Content.PlaceKind.cdefs         , corule  = Kind.createOps Content.RuleKind.cdefs-        , costrat = Kind.createOps Content.StrategyKind.cdefs         , cotile  = Kind.createOps Content.TileKind.cdefs         }   in mainSer copsSlow executorSer $ exeFrontend executorCli executorCli
− LambdaHack/Multiline.hs 
@@ -1,10 +0,0 @@--- | Template Haskell machinery for quoting multiline strings.-module Multiline (multiline) where--import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Quote as TQ---- | Handle multiline verbatim string expressions.-multiline :: TQ.QuasiQuoter-multiline  = TQ.QuasiQuoter (\x -> (TH.litE . TH.stringL) x)-               undefined undefined undefined
+ MainMenu.ascii view
@@ -0,0 +1,26 @@+----------------------------------------------------------------------------------+|                                                                                |+|                      >> LambdaHack <<                                          |+|                                                                                |+|                                                                                |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                                                                                |+|                                                                                |+|                        Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) |+----------------------------------------------------------------------------------
+ Makefile view
@@ -0,0 +1,84 @@+test: test-short test-medium test-long++test-long: testCampaign-long testCoop-long testDefense-long++test-medium: testCampaign-medium testCoop-medium testDefense-medium++testCampaign-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 500 > /tmp/stdtest.log++testCampaign-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 60 > /tmp/stdtest.log++frontendCampaign:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver++testCoop-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Permissive --savePrefix test --gameMode testCoop --frontendStd --stopAfter 500 > /tmp/stdtest.log++testCoop-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Shadow --savePrefix test --gameMode testCoop --frontendStd --stopAfter 60 > /tmp/stdtest.log++frontendCoop:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop++testDefense-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noAnim --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 500 > /tmp/stdtest.log++testDefense-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 60 > /tmp/stdtest.log++frontendDefense:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense++test-short: test-short-new test-short-load++test-short-new:+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log++test-short-load:+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log++test-travis: test-short test-medium++peekCampaign:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign++peekSkirmish:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish+++# The rest of the makefile is unmaintained at the moment.++default : dist/setup-config+	runghc Setup build++dist/setup-config : LambdaHack.cabal+	runghc Setup configure -fvty --user++vty :+	runghc Setup configure -fvty --user++gtk :+	runghc Setup configure --user++curses :+	runghc Setup configure -fcurses --user++clean :+	runghc Setup clean++ghci :+	ghci -XCPP -idist/build/autogen:Game/LambdaHack
PLAYING.md view
@@ -32,6 +32,7 @@                corridor                           #                wall (horizontal and vertical)     - and |                pillar                             O+               wall cache                         &                stairs up                          <                stairs down                        >                open door                          | and -@@ -56,9 +57,10 @@  SHIFT (or CTRL) and a movement key make the selected hero run in the indicated direction, until anything of interest is spotted. The '5' and '.' keys take-a turn to brace for combat, which gives a chance to block blows next turn.-Melee, searching for secret doors and opening closed doors can be done-by bumping into a monster, a wall and a door, respectively.+a turn to brace for combat, which gives a chance to block blows+for the remainder of the turn. Melee, searching for secret doors+and opening closed doors can be done by bumping into a monster,+a wall and a door, respectively.  Below are the default keys for major commands. Those of them that take hero time are marked with a star.@@ -104,14 +106,13 @@                }         target 10 levels deeper                0--9      select a hero anywhere in the dungeon -Commands for saving the current game, starting a new game, etc.,+Commands for saving and exiting the current game, starting a new game, etc., are listed in the Main Menu, brough up by the ESC key. Some of the game modes are multiplayer or feature multiple computer players (allied or not). The setup of the modes can be modified via a configuration file.                 key       command-               CTRL-s    save game                CTRL-x    save and exit                CTRL-r    new campaign game                CTRL-k    new skirmish game@@ -119,8 +120,12 @@                CTRL-o    new Coop game                CTRL-e    new defense game -There are also some debug and cheat options that can be specified-on the command line when starting the game server. Use at your own peril!+There are also some debug, testing and cheat options and game modes+that can be specified on the command line when starting the game server.+Use at your own peril! :) Of these, you may find the screensaver modes+the least spoilery and the most fun, e.g.:++    LambdaHack --newGame --noMore --maxFps 45 --savePrefix screensaver --gameMode screensaver   Monsters
README.md view
@@ -66,6 +66,37 @@ Vi keys (ykuhlbjn) should work everywhere regardless. Gtk works fine, too.  +Testing and debugging+---------------------++The Makefile contains many sample test commands. All that use the screensaver+game modes (AI vs. AI) and the simplest stdout frontend are gathered+in `make test`. Of these, travis runs the set contained in+`make test-travis` on each push to the repo. Commands with prefix+`frontend` run AI vs. AI games with the standard, user-friendly frontend.+Commands with prefix `peek` set up a game mode where the player peeks+into AI moves each time an AI actor dies or autosave kicks in.+Run `LambdaHack --help` to see a brief description of all debug options.+Of these, `--sniffIn` and `--sniffOut` are very useful (though verbose+and initially cryptic), for monitoring the traffic between clients+and the server. Some options in config files may turn out useful too,+though they mostly overlap with commandline options (and will be totally+merged at some point).++You can use HPC with the game as follows++    cabal clean+    cabal install --enable-library-coverage+    make test+    hpc report --hpcdir=dist/hpc/mix/LambdaHack-0.2.10/ LambdaHack+    hpc markup --hpcdir=dist/hpc/mix/LambdaHack-0.2.10/ LambdaHack++The debug option `--stopAfter` is required for any screensaver mode+game invocations that gather HPC info, because HPC needs a clean exit+(to save data files) and screensaver modes can't be cleanly stopped+in any other way.++ Further information -------------------
config.rules.default view
@@ -4,14 +4,6 @@ ; ; ~/.LambdaHack/config.rules.ini (or a similar path, depending on the OS). ; ; Warning: options are case-sensitive and only ';' for comments is permitted. -; [caves]-; ; Cave "dng" means a random choice from caves that can randomly appear;-; ; this is the default and the lack of the Escape feature is the default.-; ; Fixed caves for the first levels, then randomly picked caves.-; campaign: [(1, ("caveRogue", True)), (2, ("caveRogue", False)), (3, ("caveEmpty", False)), (10, ("caveNoise", False))]-; combat: [(3, ("caveCombat", False))]-; defense: [(1, ("dng", False)), (5, ("caveEmpty", True))]- ; [engine] ; ;dungeonRandomGenerator: 42 ; firstDeathEnds: False@@ -19,10 +11,12 @@ ; ;fovMode: Permissive ; ;fovMode: Shadow ; ;startingRandomGenerator: 42-; saveBkpClips: 100+; saveBkpClips: 500  ; [file]-; ; Names of various game files. They reside in ~/.LambdaHack or similar.+; ; Names (or prefixes) of various game files.+; ; They reside in ~/.LambdaHack or similar.+; savePrefix: save ; scoresFile: scores  ; [heroName]@@ -32,17 +26,3 @@ ; HeroName_3: Ernst Abraham ; HeroName_4: Samuel Saunders ; HeroName_5: Roger Robin--; [players]-; campaign: Players { playersHuman = [Player {playerName = "Adventuring Party", playerKind = "hero", playerInitial = 1, playerEntry = LevelId 1}], playersComputer = [Player {playerName = "Monster Hive", playerKind = "monster", playerInitial = 5, playerEntry = LevelId 3}], playersEnemy = [("Adventuring Party", "Monster Hive")], playersAlly = [] }-; skirmish: Players { playersHuman = [Player {playerName = "White", playerKind = "hero", playerInitial = 3, playerEntry = LevelId 1}], playersComputer = [Player {playerName = "Green", playerKind = "hero", playerInitial = 3, playerEntry = LevelId 1}, Player {playerName = "Horror Den", playerKind = "horror", playerInitial = 0, playerEntry = LevelId 1}], playersEnemy = [("White", "Green"), ("White", "Horror Den"), ("Green", "Horror Den")], playersAlly = [] }-; PvP: Players { playersHuman = [Player {playerName = "Red", playerKind = "hero", playerInitial = 3, playerEntry = LevelId 1}, Player {playerName = "Blue", playerKind = "hero", playerInitial = 3, playerEntry = LevelId 1}], playersComputer = [Player {playerName = "Horror Den", playerKind = "horror", playerInitial = 0, playerEntry = LevelId 1}], playersEnemy = [("Red", "Blue"), ("Red", "Horror Den"), ("Blue", "Horror Den")], playersAlly = [] }-; Coop: Players { playersHuman = [Player {playerName = "Coral", playerKind = "hero", playerInitial = 1, playerEntry = LevelId 1}, Player {playerName = "Amber", playerKind = "hero", playerInitial = 1, playerEntry = LevelId 1}], playersComputer = [Player {playerName = "Monster Hive", playerKind = "monster", playerInitial = 5, playerEntry = LevelId 3}], playersEnemy = [("Coral", "Monster Hive"), ("Amber", "Monster Hive")], playersAlly = [("Coral", "Amber")] }-; defense: Players { playersHuman = [Player {playerName = "Monster Hive", playerKind = "monster", playerInitial = 1, playerEntry = LevelId 1}], playersComputer = [Player {playerName = "Green", playerKind = "hero", playerInitial = 1, playerEntry = LevelId 1}, Player {playerName = "Yellow", playerKind = "hero", playerInitial = 2, playerEntry = LevelId 1}, Player {playerName = "Cyan", playerKind = "hero", playerInitial = 3, playerEntry = LevelId 1}], playersEnemy = [("Green", "Monster Hive"), ("Yellow", "Monster Hive"), ("Cyan", "Monster Hive")], playersAlly = [("Green", "Yellow"), ("Green", "Cyan"), ("Yellow", "Cyan")] }--; [scenario]-; campaign: Scenario { scenarioPlayers = "campaign", scenarioDungeon = "campaign" }-; skirmish: Scenario { scenarioPlayers = "skirmish", scenarioDungeon = "combat" }-; PvP: Scenario { scenarioPlayers = "PvP", scenarioDungeon = "combat" }-; Coop: Scenario { scenarioPlayers = "Coop", scenarioDungeon = "campaign" }-; defense: Scenario { scenarioPlayers = "defense", scenarioDungeon = "defense" }
config.ui.default view
@@ -14,10 +14,10 @@ ; z: Project [ApplyItem {verb = "zap", object = "wand", symbol = '/'}] ; q: Apply [ApplyItem {verb = "quaff", object = "potion", symbol = '!'}] ; r: Apply [ApplyItem {verb = "read", object = "scroll", symbol = '?'}]-; c: TriggerDir [BumpFeature {verb = "close", object = "door", feature = Closable}]-; o: TriggerDir [BumpFeature {verb = "open", object = "door", feature = Openable}]-; less: TriggerTile [BumpFeature {verb = "ascend", object = "level", feature = Cause (Ascend 1)}, BumpFeature {verb = "escape", object = "dungeon", feature = Cause Escape}]-; greater: TriggerTile [BumpFeature {verb = "descend", object = "level", feature = Cause (Descend 1)}, BumpFeature {verb = "escape", object = "dungeon", feature = Cause Escape}]+; c: AlterDir [AlterFeature {verb = "close", object = "door", feature = CloseTo "vertical closed door"}, AlterFeature {verb = "close", object = "door", feature = CloseTo "horizontal closed door"}]+; o: AlterDir [AlterFeature {verb = "open", object = "door", feature = OpenTo "vertical open door"}, AlterFeature {verb = "open", object = "door", feature = OpenTo "horizontal open door"}]+; less: TriggerTile [TriggerFeature {verb = "ascend", object = "level", feature = Cause (Ascend 1)}, TriggerFeature {verb = "escape", object = "dungeon", feature = Cause Escape}]+; greater: TriggerTile [TriggerFeature {verb = "descend", object = "level", feature = Cause (Ascend (-1))}, TriggerFeature {verb = "escape", object = "dungeon", feature = Cause Escape}] ; CTRL-r: GameRestart "campaign" ; ; TODO: pick game modes via arrow keys, not special keys ; CTRL-k: GameRestart "skirmish"@@ -47,6 +47,11 @@ ; T: MarkSuspect ; question: Help +; [file]+; ; Names (or prefixes) of various game files.+; ; They reside in ~/.LambdaHack or similar.+; savePrefix: save+ ; [macros] ; ; Handy with Vi keys: ; comma: g@@ -55,3 +60,5 @@ ; [ui] ; font: Terminus,Monospace normal normal normal normal 12 ; historyMax: 5000+; maxFps: 15+; noAnim: False
scores view

binary file changed (277 → 299 bytes)