packages feed

LambdaHack 0.2.10.6 → 0.2.12

raw patch · 123 files changed

+8270/−6320 lines, 123 filesdep +hsinidep +vectordep +vector-binary-instancesdep −ConfigFiledep ~hashabledep ~pretty-showdep ~vtybinary-added

Dependencies added: hsini, vector, vector-binary-instances

Dependencies removed: ConfigFile

Dependency ranges changed: hashable, pretty-show, vty

Files

− .travis.yml 
@@ -1,10 +0,0 @@-language: haskell--install:-  - cabal install gtk2hs-buildtools-  - cabal install -f-vty -f-curses --only-dependencies-  - cabal install -fvty -f-curses --only-dependencies-  - cabal install -f-vty -fcurses --only-dependencies--script:-  - cabal install -f-vty -f-curses && (make test-travis || (cat ~/.LambdaHack/config.rules.dump ; tail -n 200 /tmp/stdtest.log ; exit 77)) && cabal install -fvty -f-curses && (make test-travis || (cat ~/.LambdaHack/config.rules.dump ; tail -n 200 /tmp/stdtest.log ; exit 77)) && cabal install -f-vty -fcurses && (make test-travis || (cat ~/.LambdaHack/config.rules.dump ; tail -n 200 /tmp/stdtest.log ; exit 77))
Game/LambdaHack/Client.hs view
@@ -3,11 +3,11 @@ -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Client-  ( cmdClientAISem, cmdClientUISem-  , loopAI, loopUI, exeFrontend+  ( cmdClientAISem, cmdClientUISem, exeFrontend   , MonadClient, MonadClientUI, MonadClientReadServer, MonadClientWriteServer   ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Maybe @@ -27,21 +27,21 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Frontend-import Control.Exception.Assert.Sugar  storeUndo :: MonadClient m => Atomic -> m () storeUndo _atomic =   maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})     $ Nothing   -- TODO: undoAtomic atomic -cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdSerTakeTime m)+cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdTakeTimeSer m)                => CmdClientAI -> m () cmdClientAISem cmd = case cmd of   CmdAtomicAI cmdA -> do     cmds <- cmdAtomicFilterCli cmdA-    mapM_ cmdAtomicSemCli cmds-    mapM_ execCmdAtomic cmds+    mapM_ (\c -> cmdAtomicSemCli c+                 >> execCmdAtomic c) cmds     mapM_ (storeUndo . CmdAtomic) cmds   CmdQueryAI aid -> do     cmdC <- queryAI aid@@ -49,15 +49,15 @@   CmdPingAI ->     writeServer $ WaitSer $ toEnum (-1) -cmdClientUISem :: ( MonadAtomic m, MonadClientAbort m-                  , MonadClientUI m, MonadClientWriteServer CmdSer m )+cmdClientUISem :: ( MonadAtomic 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_ (\c -> cmdAtomicSemCli c+                 >> execCmdAtomic c+                 >> drawCmdAtomicUI False c) cmds     mapM_ (storeUndo . CmdAtomic) cmds  -- TODO: only store cmdA?   SfxAtomicUI sfx -> do     drawSfxAtomicUI False sfx@@ -72,28 +72,28 @@     snoMore <- getsClient $ snoMore . sdebugCli     when snoMore $ void $ displayMore ColorFull "Flushing frames."     -- Return the ping.-    writeServer $ TakeTimeSer $ WaitSer $ toEnum (-1)+    writeServer $ CmdTakeTimeSer $ 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+exeFrontend :: ( MonadAtomic m, MonadClientUI m                , MonadClientReadServer CmdClientUI m                , MonadClientWriteServer CmdSer m                , MonadAtomic n                , MonadClientReadServer CmdClientAI n-               , MonadClientWriteServer CmdSerTakeTime n )+               , MonadClientWriteServer CmdTakeTimeSer n )             => (m () -> SessionUI -> State -> StateClient                 -> ChanServer CmdClientUI CmdSer                 -> IO ())             -> (n () -> SessionUI -> State -> StateClient-                -> ChanServer CmdClientAI CmdSerTakeTime+                -> ChanServer CmdClientAI CmdTakeTimeSer                 -> IO ())             -> Kind.COps -> DebugModeCli             -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer                  -> IO ())-               -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime+               -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer                    -> IO ())                -> IO ())             -> IO ()@@ -101,7 +101,8 @@             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+  let stdRuleset = Kind.stdRuleset corule+      !sbinding = stdBinding corule sconfigUI  -- evaluate to check for errors       sdebugMode =         (\dbg -> dbg {sfont =             sfont dbg `mplus` Just (configFont sconfigUI)}) .@@ -110,7 +111,7 @@         (\dbg -> dbg {snoAnim =             snoAnim dbg `mplus` Just (configNoAnim sconfigUI)}) .         (\dbg -> dbg {ssavePrefixCli =-            ssavePrefixCli dbg `mplus` Just (configSavePrefix sconfigUI)})+            ssavePrefixCli dbg `mplus` Just (rsavePrefix stdRuleset)})         $ sdebugCli   defHist <- defHistory   let exeClientUI = executorUI $ loopUI sdebugMode cmdClientUISem
Game/LambdaHack/Client/Action.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} -- | 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@@ -7,12 +8,7 @@     MonadClient( getClient, getsClient, putClient, modifyClient, saveClient )   , MonadClientUI   , MonadClientReadServer(..), MonadClientWriteServer(..)-  , MonadClientAbort( abortWith, tryWith )   , SessionUI(..), ConnFrontend(..), connFrontend-    -- * Various ways to abort action-  , abort, abortIfWith, neverMind-    -- * Abort exception handlers-  , tryRepeatedlyWith, tryIgnore, tryWithSlide     -- * Executing actions   , mkConfigUI     -- * Accessors to the game session Reader and the Perception Reader(-like)@@ -20,63 +16,83 @@     -- * History and report   , msgAdd, msgReset, recordHistory     -- * Key input-  , getKeyOverlayCommand, getInitConfirms+  , getKeyOverlayCommand, getInitConfirms, stopPlayBack, stopRunning     -- * Display and key input   , displayFrames, displayMore, displayYesNo, displayChoiceUI     -- * Generate slideshows-  , promptToSlideshow, overlayToSlideshow+  , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow     -- * Draw frames   , drawOverlay, animate     -- * Assorted primitives   , restoreGame, removeServerSave, displayPush, scoreToSlideshow-  , rndToAction, getArenaUI, getLeaderUI-  , targetToPos, partAidLeader, partActorLeader+  , rndToAction, getArenaUI, getLeaderUI, targetDescLeader, viewedLevel+  , aidTgtToPos, aidTgtAims, leaderTgtToPos, leaderTgtAims, cursorToPos+  , partAidLeader, partActorLeader, unexploredDepth+  , getCacheBfsAndPath, getCacheBfs, accessCacheBfs, actorAimsPos+  , closestUnknown, closestSmell, furthestKnown, closestTriggers+  , closestItems, closestFoes, actorAbilities   , debugPrint   ) where +import Control.Arrow ((&&&)) import Control.Concurrent import Control.Concurrent.STM import Control.DeepSeq import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St-import Control.Monad.Writer.Strict (WriterT, lift, tell) import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Ini as Ini+import qualified Data.Ini.Reader as Ini+import qualified Data.Ini.Types as Ini+import Data.List import qualified Data.Map.Strict as M import Data.Maybe-import qualified Data.Monoid as Monoid+import Data.Monoid+import Data.Ord import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import System.Directory import System.FilePath import System.Time+import Text.Read  import Game.LambdaHack.Client.Action.ActionClass import Game.LambdaHack.Client.Binding import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.Draw-import Game.LambdaHack.Client.HumanCmd import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Ability (Ability) import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.ConfigIO as ConfigIO+import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore+import Game.LambdaHack.Common.HumanCmd 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 qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State+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.FactionKind import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind import qualified Game.LambdaHack.Frontend as Frontend+import Game.LambdaHack.Utils.File  debugPrint :: MonadClient m => Text -> m () debugPrint t = do@@ -92,45 +108,6 @@       liftIO $ atomically $ writeTQueue toF (fid, efr)   } --- | Reset the state and resume from the last backup point, i.e., invoke--- the failure continuation.-abort :: MonadClientAbort m => m a-abort = abortWith ""---- | Abort and print the given msg if the condition is true.-abortIfWith :: MonadClientAbort m => Bool -> Msg -> m a-abortIfWith True msg = abortWith msg-abortIfWith False _  = abortWith ""---- | Abort and conditionally print the fixed message.-neverMind :: MonadClientAbort m => Bool -> m a-neverMind b = abortIfWith b "never mind"---- | Take a handler and a computation. If the computation fails, the--- handler is invoked and then the computation is retried.-tryRepeatedlyWith :: MonadClientAbort m => (Msg -> m ()) -> m () -> m ()-tryRepeatedlyWith exc m =-  tryWith (\msg -> exc msg >> tryRepeatedlyWith exc m) m---- | Try the given computation and silently catch failure.-tryIgnore :: MonadClientAbort m => m () -> m ()-tryIgnore =-  tryWith (\msg -> unless (T.null msg)-                   $ assert `failure` "can't catch failure with message"-                            `twith` msg)---- | Set the current exception handler. Apart of executing it,--- draw and pass along a slide with the abort message (even if message empty).-tryWithSlide :: (MonadClientAbort m, MonadClientUI m)-             => m a -> WriterT Slideshow m a -> WriterT Slideshow m a-tryWithSlide exc h =-  let excMsg msg = do-        msgReset ""-        slides <- promptToSlideshow msg-        tell slides-        lift exc-  in tryWith excMsg h- displayFrame :: MonadClientUI m => Bool -> Maybe SingleFrame -> m () displayFrame isRunning mf = do   ConnFrontend{writeConnFrontend} <- getsSession sfconn@@ -142,16 +119,54 @@  promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM promptGetKey frontKM frontFr = do-  ConnFrontend{..} <- getsSession sfconn-  writeConnFrontend Frontend.FrontKey {..}-  readConnFrontend+  lastPlayOld <- getsClient slastPlay+  km <- case lastPlayOld of+    km : kms | null frontKM || km `elem` frontKM -> do+      displayFrame False $ Just frontFr+      modifyClient $ \cli -> cli {slastPlay = kms}+      return km+    _ -> do+      unless (null lastPlayOld) stopPlayBack  -- something went wrong+      ConnFrontend{..} <- getsSession sfconn+      writeConnFrontend Frontend.FrontKey {..}+      readConnFrontend+  (seqCurrent, seqPrevious, k) <- getsClient slastRecord+  let slastRecord = (km : seqCurrent, seqPrevious, k)+  modifyClient $ \cli -> cli {slastRecord}+  return km +stopPlayBack :: MonadClientUI m => m ()+stopPlayBack = do+  modifyClient $ \cli -> cli+    { slastPlay = []+    , slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli+                    in (seqCurrent, seqPrevious, 0)+    , swaitTimes = - swaitTimes cli+    }+  stopRunning++stopRunning :: MonadClientUI m => m ()+stopRunning = do+  srunning <- getsClient srunning+  case srunning of+    Nothing -> return ()+    Just RunParams{runLeader} -> do+      -- Switch to the original leader, from before the run start, unless dead.+      side <- getsClient sside+      fact <- getsState $ (EM.! side) . sfactionD+      arena <- getArenaUI+      s <- getState+      when (memActor runLeader arena s && not (isSpawnFact fact)) $+        modifyClient $ updateLeader runLeader s+      modifyClient (\cli -> cli { srunning = Nothing })+ -- | Display a slideshow, awaiting confirmation for each slide except the last. getInitConfirms :: MonadClientUI m                 => ColorMode -> [K.KM] -> Slideshow -> m Bool getInitConfirms dm frontClear slides = do   ConnFrontend{..} <- getsSession sfconn-  frontSlides <- mapM (drawOverlay dm) $ runSlideshow slides+  let (onBlank, ovs) = slideshow slides+  frontSlides <- mapM (drawOverlay onBlank dm) ovs   -- The first two cases are optimizations:   case frontSlides of     [] -> return True@@ -163,52 +178,6 @@       km <- readConnFrontend       return $! km /= K.escKey -getLeaderUI :: MonadClientUI m => m ActorId-getLeaderUI = do-  cli <- getClient-  case _sleader cli of-    Nothing -> assert `failure` "leader expected but not found" `twith` cli-    Just leader -> return leader--getArenaUI :: MonadClientUI m => m LevelId-getArenaUI = do-  mleader <- getsClient _sleader-  case mleader of-    Just leader -> getsState $ blid . getActorBody leader-    Nothing -> do-      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" `twith` dungeon-          return $ max minD $ min maxD $ playerEntry $ gplayer fact---- | Calculate the position of leader's target.-targetToPos :: MonadClientUI m => m (Maybe Point)-targetToPos = do-  mleader <- getsClient _sleader-  case mleader of-    Nothing -> return Nothing-    Just leader -> do-      scursor <- getsClient scursor-      lid <- getsState $ blid . getActorBody leader-      target <- getsClient $ getTarget leader-      case target of-        Just (TPos pos) -> return $ Just pos-        Just (TEnemy a _ll) -> do-          mem <- getsState $ memActor a lid  -- alive and visible?-          if mem then do-            pos <- getsState $ bpos . getActorBody a-            return $ Just pos-          else return Nothing-        Nothing -> return scursor- -- | Get the key binding. askBinding :: MonadClientUI m => m Binding askBinding = getsSession sbinding@@ -240,14 +209,12 @@                       $ EM.lookup lid fper  -- | Display an overlay and wait for a human player command.-getKeyOverlayCommand :: MonadClientUI m => Overlay -> m K.KM-getKeyOverlayCommand overlay = do-  frame <- drawOverlay ColorFull overlay-  keyb <- askBinding+getKeyOverlayCommand :: MonadClientUI m => Bool -> Overlay -> m K.KM+getKeyOverlayCommand onBlank overlay = do+  frame <- drawOverlay onBlank ColorFull overlay   -- Give the previous client time to display his frames.   liftIO $ threadDelay 1000-  km <- promptGetKey [] frame-  return $! fromMaybe km $ M.lookup km $ kmacro keyb+  promptGetKey [] frame  -- | Push frames or delays to the frame queue. displayFrames :: MonadClientUI m => Frames -> m ()@@ -271,42 +238,42 @@ displayMore dm prompt = do   slides <- promptToSlideshow $ prompt <+> moreMsg   -- Two frames drawn total (unless 'prompt' very long).-  getInitConfirms dm [] $ slides Monoid.<> toSlideshow [[]]+  getInitConfirms dm [] $ slides <> toSlideshow False [[]]  -- | Print a yes/no question and return the player's answer. Use black -- and white colours to turn player's attention to the choice. displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool displayYesNo dm prompt = do   sli <- promptToSlideshow $ prompt <+> yesnoMsg-  frame <- drawOverlay dm $ head $ runSlideshow sli+  frame <- drawOverlay False dm $ head . snd $ slideshow sli   getYesNo frame  -- TODO: generalize getInitConfirms and displayChoiceUI to a single op -- | Print a prompt and an overlay and wait for a player keypress. -- If many overlays, scroll screenfuls with SPACE. Do not wrap screenfuls -- (in some menus @?@ cycles views, so the user can restart from the top).-displayChoiceUI :: (MonadClientAbort m, MonadClientUI m)-                => Msg -> Overlay -> [K.KM] -> m K.KM+displayChoiceUI :: MonadClientUI m+                => Msg -> Overlay -> [K.KM] -> m (Either Slideshow K.KM) displayChoiceUI prompt ov keys = do-  slides <- fmap runSlideshow $ overlayToSlideshow (prompt <> ", ESC]") ov+  (_, ovs) <- fmap slideshow $ overlayToSlideshow (prompt <> ", ESC]") ov   let legalKeys =         [ K.KM {key=K.Space, modifier=K.NoModifier}         , K.escKey ]         ++ keys-      loop [] = neverMind True+      loop [] = fmap Left $ promptToSlideshow "never mind"       loop (x : xs) = do-        frame <- drawOverlay ColorFull x+        frame <- drawOverlay False ColorFull x         km@K.KM {..} <- promptGetKey legalKeys frame         case key of-          K.Esc -> neverMind True+          K.Esc -> fmap Left $ promptToSlideshow "never mind"           K.Space -> loop xs-          _ -> return km-  loop slides+          _ -> return $ Right km+  loop ovs  -- | The prompt is shown after the current message, but not added to history. -- This is useful, e.g., in targeting mode, not to spam history. promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow-promptToSlideshow prompt = overlayToSlideshow prompt []+promptToSlideshow prompt = overlayToSlideshow prompt emptyOverlay  -- | The prompt is shown after the current message at the top of each slide. -- Together they may take more than one line. The prompt is not added@@ -315,23 +282,35 @@ overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow overlayToSlideshow prompt overlay = do   lid <- getArenaUI-  Level{lysize} <- getLevel lid  -- TODO: screen length or viewLevel+  Level{lxsize, lysize} <- getLevel lid  -- TODO: screen length or viewLevel   sreport <- getsClient sreport-  let msg = splitReport (addMsg sreport prompt)-  return $! splitOverlay lysize msg overlay+  let msg = splitReport lxsize (addMsg sreport prompt)+  return $! splitOverlay False (lysize + 1) msg overlay +overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow+overlayToBlankSlideshow prompt overlay = do+  lid <- getArenaUI+  Level{lysize} <- getLevel lid  -- TODO: screen length or viewLevel+  return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay+ -- | Draw the current level with the overlay on top.-drawOverlay :: MonadClientUI m => ColorMode -> Overlay -> m SingleFrame-drawOverlay dm over = do+drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame+drawOverlay onBlank dm over = do   cops <- getsState scops-  stgtMode <- getsClient stgtMode-  arena <- getArenaUI-  let lid = maybe arena tgtLevelId stgtMode+  lid <- viewedLevel   mleader <- getsClient _sleader   s <- getState   cli <- getClient   per <- getPerFid lid-  return $! draw dm cops per lid mleader cli s over+  tgtPos <- leaderTgtToPos+  cursorPos <- cursorToPos+  let pathFromLeader leader =+        maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos+  bfsmpath <- maybe (return Nothing) pathFromLeader mleader+  tgtDesc <- maybe (return "------") targetDescLeader mleader+  cursorDesc <- targetDescCursor+  return $! draw onBlank dm cops per lid mleader cursorPos tgtPos+                 bfsmpath cli s cursorDesc tgtDesc over  -- TODO: if more slides, don't take head, but do as in getInitConfirms, -- but then we have to clear the messages or they get redisplayed@@ -341,8 +320,8 @@ displayPush :: MonadClientUI m => m () displayPush = do   sls <- promptToSlideshow ""-  let slide = head $ runSlideshow sls-  frame <- drawOverlay ColorFull slide+  let slide = head . snd $ slideshow sls+  frame <- drawOverlay False ColorFull slide   -- Visually speed up (by remving all empty frames) the show of the sequence   -- of the move frames if the player is running.   srunning <- getsClient srunning@@ -350,36 +329,43 @@  scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow scoreToSlideshow total status = do+  fid <- getsClient sside+  fact <- getsState $ (EM.! fid) . sfactionD   table <- getsState shigh   time <- getsState stime   date <- liftIO getClockTime-  let showScore (ntable, pos) = HighScore.slideshow ntable pos status-  return $! maybe Monoid.mempty showScore-            $ HighScore.register table total time status date+  scurDifficulty <- getsClient scurDifficulty+  let showScore (ntable, pos) = HighScore.highSlideshow ntable pos status+      diff | not $ playerUI $ gplayer fact = 0+           | otherwise = scurDifficulty+  return $! maybe mempty showScore+            $ HighScore.register table total time status date diff  restoreGame :: MonadClient m => m (Maybe (State, StateClient)) restoreGame = do   Kind.COps{corule} <- getsState scops-  let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule+  let stdRuleset = Kind.stdRuleset corule+      pathsDataFile = rpathsDataFile stdRuleset+      cfgUIName = rcfgUIName stdRuleset   side <- getsClient sside   isAI <- getsClient sisAI   prefix <- getsClient $ ssavePrefixCli . sdebugCli-  ConfigUI{ configAppDataDir-          , configUICfgFile } <- getsClient sconfigUI-  let copies = [(configUICfgFile <.> ".default", configUICfgFile <.> ".ini")]+  let copies = [( "GameDefinition" </> cfgUIName <.> "default"+                , cfgUIName <.> "ini" )]       name = fromMaybe "save" prefix <.> saveName side isAI-  liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile+  liftIO $ Save.restoreGame name 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+  dataDir <- liftIO appDataDir+  let serverSaveFile = dataDir                        </> fromMaybe "save" prefix                        <.> serverSaveName-  liftIO $ renameFile serverSaveFile (serverSaveFile ++ ".bkp")+  bSer <- liftIO $ doesFileExist serverSaveFile+  when bSer $ liftIO $ renameFile serverSaveFile (serverSaveFile <.> "bkp")  -- | Invoke pseudo-random computation with the generator kept in the state. rndToAction :: MonadClient m => Rnd a -> m a@@ -400,13 +386,22 @@   cli <- getClient   s <- getState   per <- getPerFid arena+  tgtPos <- leaderTgtToPos+  cursorPos <- cursorToPos+  let pathFromLeader leader =+        maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos+  bfsmpath <- maybe (return Nothing) pathFromLeader mleader+  tgtDesc <- maybe (return "------") targetDescLeader mleader+  cursorDesc <- targetDescCursor   let over = renderReport sreport-      topLineOnly = truncateMsg lxsize over-      basicFrame = draw ColorFull cops per arena mleader cli s [topLineOnly]+      topLineOnly = truncateToOverlay lxsize over+      basicFrame =+        draw False ColorFull cops per arena mleader+             cursorPos tgtPos bfsmpath cli s cursorDesc tgtDesc topLineOnly   snoAnim <- getsClient $ snoAnim . sdebugCli-  return $ if fromMaybe False snoAnim-           then [Just basicFrame]-           else renderAnim lxsize lysize basicFrame anim+  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.@@ -425,43 +420,468 @@   b <- getsState $ getActorBody aid   partActorLeader aid b -parseConfigUI :: FilePath -> ConfigIO.CP -> ConfigUI-parseConfigUI dataDir cp =-  let mkKey s =-        case K.keyTranslate s of-          K.Unknown _ ->-            assert `failure` "unknown config file key" `twith` (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}-      configCommands =-        let mkCommand (key, def) = (mkKM key, read def :: HumanCmd)-            section = ConfigIO.getItems cp "commands"+parseConfigUI :: Ini.Config -> ConfigUI+parseConfigUI cfg =+  let configCommands =+        let mkCommand (ident, keydef) =+              case stripPrefix "Macro_" ident of+                Just _ ->+                  let (key, def) = read keydef+                  in (K.mkKM key, def :: (CmdCategory, HumanCmd))+                Nothing -> assert `failure` "wrong macro id" `twith` ident+            section = Ini.allItems "extra_commands" cfg         in map mkCommand section-      configAppDataDir = dataDir-      configUICfgFile = "config.ui"-      configSavePrefix = ConfigIO.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" `twith` toTr-                 else (fromTr, toTr)-            section = ConfigIO.getItems cp "macros"-        in map trMacro section-      configFont = ConfigIO.get cp "ui" "font"-      configHistoryMax = ConfigIO.get cp "ui" "historyMax"-      configMaxFps = ConfigIO.get cp "ui" "maxFps"-      configNoAnim = ConfigIO.get cp "ui" "noAnim"+      configHeroNames =+        let toNumber (ident, name) =+              case stripPrefix "HeroName_" ident of+                Just n -> (read n, T.pack name)+                Nothing -> assert `failure` "wrong hero name id" `twith` ident+            section = Ini.allItems "hero_names" cfg+        in map toNumber section+      getOption :: forall a. Read a => String -> a+      getOption optionName =+        let lookupFail :: forall b. String -> b+            lookupFail err =+              assert `failure` ("config file access failed:" <+> T.pack err)+                     `twith` (optionName, cfg)+            s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg+        in either lookupFail id $ readEither s+      configFont = getOption "font"+      configHistoryMax = getOption "historyMax"+      configMaxFps = getOption "maxFps"+      configNoAnim = getOption "noAnim"+      configRunStopMsgs = getOption "runStopMsgs"   in ConfigUI{..}  -- | Read and parse UI config file. mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI mkConfigUI corule = do-  let cpUIDefault = rcfgUIDefault $ Kind.stdRuleset corule-  dataDir <- ConfigIO.appDataDir-  cpUI <- ConfigIO.mkConfig cpUIDefault $ dataDir </> "config.ui.ini"-  let conf = parseConfigUI dataDir cpUI-  -- Catch syntax errors ASAP,+  let stdRuleset = Kind.stdRuleset corule+      cfgUIName = rcfgUIName stdRuleset+      commentsUIDefault = init $ map (drop 2) $ lines $ rcfgUIDefault stdRuleset  -- TODO: init is a hack until Ini accepts empty files+      sUIDefault = unlines commentsUIDefault+      cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault+  dataDir <- appDataDir+  let userPath = dataDir </> cfgUIName <.> "ini"+  cfgUser <- do+    cpExists <- doesFileExist userPath+    if not cpExists+      then return Ini.emptyConfig+      else do+        sUser <- readFile userPath+        return $! either (assert `failure`) id $ Ini.parse sUser+  let cfgUI = M.unionWith M.union cfgUser cfgUIDefault  -- user cfg preferred+      conf = parseConfigUI cfgUI+  -- Catch syntax errors in complex expressions ASAP,   return $! deepseq conf conf++-- | Get cached BFS data and path or, if not stored, generate,+-- store and return. Due to laziness, they are not calculated until needed.+getCacheBfsAndPath :: forall m. MonadClient m+                   => ActorId -> Point+                   -> m (PointArray.Array BfsDistance, Maybe [Point])+getCacheBfsAndPath aid target = do+  seps <- getsClient seps+  let pathAndStore :: PointArray.Array BfsDistance+                   -> m (PointArray.Array BfsDistance, Maybe [Point])+      pathAndStore bfs = do+        computePath <- computePathBFS aid+        let mpath = computePath target seps bfs+        modifyClient $ \cli ->+          cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)}+        return (bfs, mpath)+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just (bfs, targetOld, sepsOld, mpath) | targetOld == target+                                            && sepsOld == seps ->+      return (bfs, mpath)+    Just (bfs, _, _, _) -> pathAndStore bfs+    Nothing -> do+      bfs <- computeBFS aid+      pathAndStore bfs++getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)+{-# INLINE getCacheBfs #-}+getCacheBfs aid = do+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just (bfs, _, _, _) -> return bfs+    Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0)++computeBFS :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)+computeBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do+  b <- getsState $ getActorBody aid+  Level{lxsize, lysize} <- getLevel $ blid b+  let origin = bpos b+      vInitial = PointArray.replicateA lxsize lysize apartBfs+  -- Here we don't want '$!', because we want the BFS data lazy.+  return ${-keep it!-} fillBfs isEnterable passUnknown origin vInitial++computePathBFS :: MonadClient m+               => ActorId+               -> m (Point -> Int -> PointArray.Array BfsDistance+                     -> Maybe [Point])+computePathBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do+  b <- getsState $ getActorBody aid+  let origin = bpos b+  -- Here we don't want '$!', because we want the BFS data lazy.+  return ${-keep it!-} findPathBfs isEnterable passUnknown origin++computeAnythingBFS :: MonadClient m+                   => ((Point -> Point -> MoveLegal)+                       -> (Point -> Point -> Bool)+                       -> ActorId+                       -> m a)+                   -> ActorId+                   -> m a+computeAnythingBFS fAnything aid = do+  cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  smarkSuspect <- getsClient smarkSuspect+  sisAI <- getsClient sisAI+  -- We treat doors as an open tile and don't add an extra step for opening+  -- the doors, because other actors open and use them, too,+  -- so it's amortized. We treat unknown tiles specially.+  let -- Suspect tiles treated as a kind of unknown.+      passSuspect = smarkSuspect || sisAI  -- AI checks suspects ASAP+      unknownId = ouniqGroup "unknown space"+      chAccess = checkAccess cops lvl+      chDoorAccess = checkDoorAccess cops lvl+      conditions = catMaybes [chAccess, chDoorAccess]+      -- Legality of move from a known tile, assuming doors freely openable.+      isEnterable :: Point -> Point -> MoveLegal+      isEnterable spos tpos =+        let tt = lvl `at` tpos+            allOK = all (\f -> f spos tpos) conditions+        in if tt == unknownId+           then if allOK+                then MoveToUnknown+                else MoveBlocked+           else if Tile.isSuspect cotile tt+                then if passSuspect && allOK+                     then MoveToUnknown+                     else MoveBlocked+                else if Tile.isPassable cotile tt && allOK+                     then MoveToOpen+                     else MoveBlocked+      -- Legality of move from an unknown tile, assuming unknown are open.+      passUnknown :: Point -> Point -> Bool+      passUnknown = case chAccess of  -- spos is unknown, so not a door+        Nothing -> \_ tpos -> let tt = lvl `at` tpos+                              in tt == unknownId+                                 || passSuspect && Tile.isSuspect cotile tt+        Just ch -> \spos tpos -> let tt = lvl `at` tpos+                                 in (tt == unknownId+                                     || passSuspect+                                        && Tile.isSuspect cotile tt)+                                    && ch spos tpos+  fAnything isEnterable passUnknown aid++accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)+{-# INLINE accessCacheBfs #-}+accessCacheBfs aid target = do+  bfs <- getCacheBfs aid+  return $! accessBfs bfs target++actorAimsPos :: MonadClient m => ActorId -> Point -> m Bool+{-# INLINE actorAimsPos #-}+actorAimsPos aid target = do+  bfs <- getCacheBfs aid+  b <- getsState $ getActorBody aid+  return $! posAimsPos bfs (bpos b) target++targetDesc :: MonadClientUI m => Maybe Target -> m Text+targetDesc target = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  case target of+    Just (TEnemy a _) ->+      getsState $ bname . getActorBody a+    Just (TEnemyPos _ lid p _) ->+      return $! if lid == lidV+                then "hot spot" <+> (T.pack . show) p+                else "a hot spot on level" <+> tshow (abs $ fromEnum lid)+    Just (TPoint lid p) ->+      return $! if lid == lidV+                then "exact spot" <+> (T.pack . show) p+                else "an exact spot on level" <+> tshow (abs $ fromEnum lid)+    Just TVector{} ->+      case mleader of+        Nothing -> return "a relative shift"+        Just aid -> do+          tgtPos <- aidTgtToPos aid lidV target+          let invalidMsg = "an invalid relative shift"+              validMsg p = "shift to" <+> (T.pack . show) p+          return $! maybe invalidMsg validMsg tgtPos+    Nothing -> return "cursor location"++targetDescLeader :: MonadClientUI m => ActorId -> m Text+targetDescLeader leader = do+  tgt <- getsClient $ getTarget leader+  targetDesc tgt++targetDescCursor :: MonadClientUI m => m Text+targetDescCursor = do+  scursor <- getsClient scursor+  targetDesc $ Just scursor++getLeaderUI :: MonadClientUI m => m ActorId+getLeaderUI = do+  cli <- getClient+  case _sleader cli of+    Nothing -> assert `failure` "leader expected but not found" `twith` cli+    Just leader -> return leader++getArenaUI :: MonadClientUI m => m LevelId+getArenaUI = do+  mleader <- getsClient _sleader+  case mleader of+    Just leader -> getsState $ blid . getActorBody leader+    Nothing -> do+      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" `twith` dungeon+          return $! max minD $ min maxD $ playerEntry $ gplayer fact++viewedLevel :: MonadClientUI m => m LevelId+viewedLevel = do+  arena <- getArenaUI+  stgtMode <- getsClient stgtMode+  return $! maybe arena tgtLevelId stgtMode++-- | Calculate the position of an actor's target.+aidTgtToPos :: MonadClient m+            => ActorId -> LevelId -> Maybe Target -> m (Maybe Point)+aidTgtToPos aid lidV tgt =+  case tgt of+    Just (TEnemy a _) -> do+      body <- getsState $ getActorBody a+      return $! if blid body == lidV+                then Just (bpos body)+                else Nothing+    Just (TEnemyPos _ lid p _) ->+      return $! if lid == lidV then Just p else Nothing+    Just (TPoint lid p) ->+      return $! if lid == lidV then Just p else Nothing+    Just (TVector v) -> do+      b <- getsState $ getActorBody aid+      Level{lxsize, lysize} <- getLevel lidV+      let shifted = shiftBounded lxsize lysize (bpos b) v+      return $! if shifted == bpos b && v /= Vector 0 0+                then Nothing+                else Just shifted+    Nothing -> do+      scursor <- getsClient scursor+      aidTgtToPos aid lidV $ Just scursor++-- | Check whether one is permitted to aim at a target+-- (this is only checked for actors; positions let player+-- shoot at obstacles, e.g., to destroy them).+-- This assumes @aidTgtToPos@ does not return @Nothing@.+--+-- Note: Perception is not enough for the check,+-- because the target actor can be obscured by a glass wall+-- or be out of sight range, but in weapon range.+aidTgtAims :: MonadClient m+           => ActorId -> LevelId -> Maybe Target -> m (Maybe Text)+aidTgtAims aid lidV tgt = do+  case tgt of+    Just (TEnemy a _) -> do+      body <- getsState $ getActorBody a+      let pos = bpos body+      b <- getsState $ getActorBody aid+      if blid b == lidV then do+        aims <- actorAimsPos aid pos+        if aims+          then return Nothing+          else return $ Just "aiming line to the opponent blocked"+      else return $ Just "target opponent not on this level"+    Just TEnemyPos{} -> return $ Just "target opponent not visible"+    Just TPoint{} -> return Nothing+    Just TVector{} -> return Nothing+    Nothing -> do+      scursor <- getsClient scursor+      aidTgtAims aid lidV $ Just scursor++leaderTgtToPos :: MonadClientUI m => m (Maybe Point)+leaderTgtToPos = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  case mleader of+    Nothing -> return Nothing+    Just aid -> do+      tgt <- getsClient $ getTarget aid+      aidTgtToPos aid lidV tgt++leaderTgtAims :: MonadClientUI m => m (Maybe Text)+leaderTgtAims = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  case mleader of+    Nothing -> return $ Just "no leader to target with"+    Just aid -> do+      tgt <- getsClient $ getTarget aid+      aidTgtAims aid lidV tgt++cursorToPos :: MonadClientUI m => m (Maybe Point)+cursorToPos = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  scursor <- getsClient scursor+  case mleader of+    Nothing -> return Nothing+    Just aid -> aidTgtToPos aid lidV $ Just scursor++-- | Furthest (wrt paths) known position, except under the actor.+furthestKnown :: MonadClient m => ActorId -> m (Maybe Point)+furthestKnown aid = do+  bfs <- getCacheBfs aid+  getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA+                                     , PointArray.maxLastIndexA ]+  let furthestPos = getMaxIndex bfs+      dist = bfs PointArray.! furthestPos+  return $! if dist <= apartBfs+            then assert `failure` (aid, furthestPos, dist)+            else if dist == succ apartBfs  -- bpos of aid+                 then Nothing+                 else Just furthestPos++-- | Closest reachable unknown tile position, if any.+closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)+closestUnknown aid = do+  bfs <- getCacheBfs aid+  getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA+                                     , PointArray.minLastIndexA ]+  let closestPos = getMinIndex bfs+      dist = bfs PointArray.! closestPos+  if dist >= apartBfs then do+    body <- getsState $ getActorBody aid+    smarkSuspect <- getsClient smarkSuspect+    sisAI <- getsClient sisAI+    let passSuspect = smarkSuspect || sisAI+    when passSuspect $  -- explored fully, including suspect tiles+      modifyClient $ \cli ->+        cli {sexplored = ES.insert (blid body) (sexplored cli)}+    return Nothing+  else return $ Just closestPos++-- TODO: this is costly, because target has to be changed every+-- turn when walking along trail. But inverting the sort and going+-- to the newest smell, while sometimes faster, may result in many+-- actors following the same trail, unless we wipe the trail as soon+-- as target is assigned (but then we don't know if we should keep the target+-- or not, because somebody already followed it). OTOH, trails are not+-- common and so if wiped they can't incur a large total cost.+-- TODO: remove targets where the smell is likely to get too old by the time+-- the actor gets there.+-- | Finds smells closest to the actor, except under the actor.+closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))]+closestSmell aid = do+  body <- getsState $ getActorBody aid+  Level{lsmell} <- getLevel $ blid body+  let smells = EM.assocs lsmell+  case smells of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells+          ds = filter (\(d, _) -> d /= 0) ts  -- bpos of aid+      return $! sortBy (comparing (fst &&& timeNegate . snd . snd)) ds++-- TODO: We assume linear dungeon in @unexploredD@,+-- because otherwise we'd need to calculate shortest paths in a graph, etc.+-- | Closest (wrt paths) triggerable open tiles.+-- The second argument can ever be true only if there's+-- no escape from the dungeon.+closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point]+closestTriggers onlyDir exploredToo aid = do+  Kind.COps{cotile} <- getsState scops+  body <- getsState $ getActorBody aid+  lvl <- getLevel $ blid body+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  unexploredD <- unexploredDepth+  let allExplored = ES.size explored == EM.size dungeon+      unexUp = onlyDir /= Just False && unexploredD 1 (blid body)+      unexDown = onlyDir /= Just True && unexploredD (-1) (blid body)+      unexEffect (Effect.Ascend p) = if p > 0 then unexUp else unexDown+      unexEffect _ =+        -- Escape (or guard) only after exploring, for high score, etc.+        allExplored+      isTrigger+        | exploredToo = \t -> Tile.isWalkable cotile t+                              && not (null $ Tile.causeEffects cotile t)+        | otherwise = \t -> Tile.isWalkable cotile t+                            && any unexEffect (Tile.causeEffects cotile t)+      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]+      f acc p t = if isTrigger t then p : acc else acc+  let triggersAll = PointArray.ifoldlA f [] $ ltile lvl+      -- Don't target stairs under the actor. Most of the time they+      -- are blocked and stay so, so we seek other stairs, if any.+      -- If no other stairs in this direction, let's wait here.+      triggers | length triggersAll > 1 = delete (bpos body) triggersAll+               | otherwise = triggersAll+  case triggers of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) triggers+      return $! map snd $ sortBy (comparing fst) ds++unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)+unexploredDepth = do+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  let allExplored = ES.size explored == EM.size dungeon+      unexploredD p =+        let unex lid = allExplored && lescape (dungeon EM.! lid)+                       || ES.notMember lid explored+                       || unexploredD p lid+        in any unex . ascendInBranch dungeon p+  return unexploredD++-- | Closest (wrt paths) items.+closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, ItemBag))])+closestItems aid = do+  body <- getsState $ getActorBody aid+  Level{lfloor} <- getLevel $ blid body+  let items = EM.assocs lfloor+  case items of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) items+      return $! sortBy (comparing fst) ds++-- | Closest (wrt paths) enemy actors.+closestFoes :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]+closestFoes aid = do+  body <- getsState $ getActorBody aid+  fact <- getsState $ \s -> sfactionD s EM.! bfid body+  foes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid body)+  case foes of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes+      return $! sortBy (comparing fst) ds++actorAbilities :: MonadClient m => ActorId -> Maybe ActorId -> m [Ability]+actorAbilities aid mleader = do+  Kind.COps{ coactor=Kind.Ops{okind}+           , cofaction=Kind.Ops{okind=fokind} } <- getsState scops+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  let factionAbilities+        | Just aid == mleader = fAbilityLeader $ fokind $ gkind fact+        | otherwise = fAbilityOther $ fokind $ gkind fact+  return $! acanDo (okind $ bkind body) `intersect` factionAbilities
Game/LambdaHack/Client/Action/ActionClass.hs view
@@ -4,15 +4,12 @@ -- and 'TypeAction'. module Game.LambdaHack.Client.Action.ActionClass where -import Control.Monad.Writer.Strict (WriterT (WriterT), lift, runWriterT)-import Data.Monoid import qualified Game.LambdaHack.Common.Key as K  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.Frontend (FrontReq)  -- | The information that is constant across a client playing session,@@ -42,37 +39,14 @@   liftIO       :: IO a -> m a   saveClient   :: m () -instance (Monoid a, MonadClient m) => MonadClient (WriterT a m) where-  getClient    = lift getClient-  getsClient   = lift . getsClient-  modifyClient = lift . modifyClient-  putClient    = lift . putClient-  liftIO       = lift . liftIO-  saveClient   = lift saveClient- class MonadClient m => MonadClientUI m where   getsSession  :: (SessionUI -> a) -> m a -instance (Monoid a, MonadClientUI m) => MonadClientUI (WriterT a m) where-  getsSession  = lift . getsSession- 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,-  -- second is the computation the handler scopes over.-  tryWith      :: (Msg -> m a) -> m a -> m a-  -- Abort with the given message.-  abortWith    :: Msg -> m a--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 =
Game/LambdaHack/Client/Action/ActionType.hs view
@@ -1,133 +1,92 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving,+             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' -- to expose the executor to any code using the library. module Game.LambdaHack.Client.Action.ActionType-  ( FunActionCli, ActionCli, executorCli+  ( ActionCli, executorCli   ) where  import Control.Applicative import Control.Concurrent.STM-import Control.Monad-import qualified Data.EnumMap.Strict as EM+import qualified Control.Monad.IO.Class as IO+import Control.Monad.Trans.State.Strict hiding (State) 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 d a =-   SessionUI                          -- ^ client UI setup data-   -> (ChanServer c d, Save.ChanSave (State, StateClient))-                                      -- ^ this client connection information-   -> (State -> StateClient -> a -> IO ())-                                      -- ^ continuation-   -> (R.StdGen -> Msg -> IO ())      -- ^ failure/reset continuation-   -> State                           -- ^ current local state-   -> StateClient                     -- ^ current client state-   -> IO ()---- | Client parts of actions of human and computer player characters.-newtype ActionCli c d a = ActionCli {runActionCli :: FunActionCli c d a}---- | Invokes the action continuation on the provided argument.-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 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 d) where-  return = returnActionCli-  (>>=)  = bindActionCli--instance Applicative (ActionCli c d) where-    pure  = return-    (<*>) = ap---- TODO: make sure fmap is inlined and all else is inlined here and elsewhere-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)+data CliState c d = CliState+  { cliState   :: !State             -- ^ current global state+  , cliClient  :: !StateClient       -- ^ current client state+  , cliDict    :: !(ChanServer c d)  -- ^ this client connection information+  , cliToSave  :: !(Save.ChanSave (State, StateClient))+                                     -- ^ connection to the save thread+  , cliSession :: SessionUI          -- ^ UI setup data, empty for AI clients+  } -instance MonadClientAbort (ActionCli c d) where-  tryWith exc m  =-    ActionCli (\c d k a s cli ->-             let runA srandom msg =-                   runActionCli (exc msg) c d k a s cli {srandom}-             in runActionCli m c d k runA s cli)-  abortWith msg  = ActionCli (\_c _d _k a _s cli -> a (srandom cli) msg)+-- | Server state transformation monad.+newtype ActionCli c d a =+    ActionCli {runActionCli :: StateT (CliState c d) IO a}+  deriving (Monad, Functor, Applicative)  instance MonadActionRO (ActionCli c d) where-  getState       = ActionCli (\_c _d k _a s cli -> k s cli s)-  getsState      = (`fmap` getState)+  getState    = ActionCli $ gets cliState+  getsState f = ActionCli $ gets $ f . cliState  instance MonadAction (ActionCli c d) where-  modifyState f  = ActionCli (\_c _d k _a s cli -> k (f s) cli ())-  putState       = modifyState . const+  modifyState f = ActionCli $ state $ \cliS ->+    let newCliS = cliS {cliState = f $ cliState cliS}+    in newCliS `seq` ((), newCliS)+  putState    s = ActionCli $ state $ \cliS ->+    let newCliS = cliS {cliState = s}+    in newCliS `seq` ((), newCliS)  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 ())+  getClient      = ActionCli $ gets cliClient+  getsClient   f = ActionCli $ gets $ f . cliClient+  modifyClient f = ActionCli $ state $ \cliS ->+    let newCliS = cliS {cliClient = f $ cliClient cliS}+    in newCliS `seq` ((), newCliS)+  putClient    s = ActionCli $ state $ \cliS ->+    let newCliS = cliS {cliClient = s}+    in newCliS `seq` ((), newCliS)+  liftIO         = ActionCli . IO.liftIO+  saveClient     = ActionCli $ do+    s <- gets cliState+    cli <- gets cliClient+    toSave <- gets cliToSave+    IO.liftIO $ Save.saveToChan toSave (s, cli)  instance MonadClientUI (ActionCli c d) where-  getsSession f  = ActionCli (\c _d k _a s cli -> k s cli (f c))+  getsSession f  = ActionCli $ gets $ f . cliSession  instance MonadClientReadServer c (ActionCli c d) where-  readServer     =-    ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do-                  ccmd <- atomically . readTQueue $ fromServer-                  k s cli ccmd)+  readServer     = ActionCli $ do+    ChanServer{fromServer} <- gets cliDict+    IO.liftIO $ atomically . readTQueue $ fromServer  instance MonadClientWriteServer d (ActionCli c d) where-  writeServer scmd =-    ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do-                  atomically . writeTQueue toServer $ scmd-                  k s cli ())+  writeServer scmd = ActionCli $ do+    ChanServer{toServer} <- gets cliDict+    IO.liftIO $ atomically . writeTQueue toServer $ scmd  -- | 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 =+executorCli m cliSession cliState cliClient cliDict =   let saveFile (_, cli2) =-        configAppDataDir (sconfigUI cli2)-        </> fromMaybe "save" (ssavePrefixCli (sdebugCli 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+      exe cliToSave =+        evalStateT (runActionCli m) CliState{..}   in Save.wrapInSaves saveFile exe
Game/LambdaHack/Client/AtomicSemCli.hs view
@@ -6,11 +6,12 @@   , drawCmdAtomicUI, drawSfxAtomicUI   ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Maybe-import qualified Data.Monoid as Monoid+import Data.Monoid import qualified NLP.Miniutter.English as MU  import Game.LambdaHack.Client.Action@@ -33,11 +34,13 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.TileKind-import Control.Exception.Assert.Sugar  -- * CmdAtomicAI @@ -46,9 +49,18 @@ -- of commands kept for each command received. cmdAtomicFilterCli :: MonadClient m => CmdAtomic -> m [CmdAtomic] cmdAtomicFilterCli cmd = case cmd of+  MoveActorA aid _ toP -> do+    cmdSml <- deleteSmell aid toP+    return $ [cmd] ++ cmdSml+  DisplaceActorA source target -> do+    bs <- getsState $ getActorBody source+    bt <- getsState $ getActorBody target+    cmdSource <- deleteSmell source (bpos bt)+    cmdTarget <- deleteSmell target (bpos bs)+    return $ [cmd] ++ cmdSource ++ cmdTarget   AlterTileA lid p fromTile toTile -> do-    Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops-    lvl@Level{lxsize} <- getLevel lid+    Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops+    lvl <- getLevel lid     let t = lvl `at` p     if t == fromTile       then return [cmd]@@ -61,7 +73,7 @@         let subject = ""  -- a hack, we we don't handle adverbs well             verb = "turn into"             msg = makeSentence [ "the", MU.Text $ tname $ okind t-                               , "at position", MU.Text $ showPoint lxsize p+                               , "at position", MU.Text $ tshow p                                , "suddenly"  -- adverb                                , MU.SubjectVerbSg subject verb                                , MU.AW $ MU.Text $ tname $ okind toTile ]@@ -72,17 +84,40 @@     b <- getsState $ getActorBody aid     lvl <- getLevel $ blid b     let t = lvl `at` p-    if t == toTile-      then -- Already knows the tile fully.-           return []-      else if t == fromTile-           then -- Fully ignorant. (No intermediate knowledge possible.)-                return [ AlterTileA (blid b) p fromTile toTile  -- reveal tile-                       , cmd  -- show the message-                       ]+    return $!+      if t == fromTile+      then -- Fully ignorant. (No intermediate knowledge possible.)+           [ cmd  -- show the message+           , AlterTileA (blid b) p fromTile toTile  -- reveal tile+           ]+      else if t == toTile+           then [cmd]  -- Already knows the tile fully, only confirm.            else -- Misguided.                 assert `failure` "LoseTile fails to reset memory"                        `twith` (aid, p, fromTile, toTile, b, t, cmd)+  SpotTileA lid ts -> do+    Kind.COps{cotile} <- getsState scops+    lvl <- getLevel lid+    -- We ignore the server resending us hidden versions of the tiles+    -- (and resending us the same data we already got).+    -- If the tiles are changed to other variants of the hidden tile,+    -- we can still verify by searching, and the UI warns us "obscured".+    let notKnown (p, t) = let tClient = lvl `at` p+                          in t /= tClient+                             && (not (isSecretPos lvl p)+                                 || t /= Tile.hideAs cotile tClient)+        newTs = filter notKnown ts+    return $! if null newTs then [] else [SpotTileA lid newTs]+  AlterSmellA lid p fromSm _toSm -> do+    lvl <- getLevel lid+    let msml = EM.lookup p $ lsmell lvl+    return $ if msml /= fromSm then+               -- Revert to the server smell before server command executes.+               -- This is needed due to our hacky removal of traversed smells+               -- in @deleteSmell@.+               [AlterSmellA lid p msml fromSm, cmd]+             else+               [cmd]   DiscoverA _ _ iid _ -> do     disco <- getsClient sdisco     item <- getsState $ getItemBody iid@@ -95,14 +130,14 @@     if jkindIx item `EM.notMember` disco       then return []       else return [cmd]-  PerceptionA lid outPA inPA -> do+  PerceptionA lid outPer inPer -> do     -- Here we cheat by setting a new perception outright instead of     -- in @cmdAtomicSemCli@, to avoid computing perception twice.     -- TODO: try to assert similar things as for @atomicRemember@:     -- that posCmdAtomic of all the Lose* commands was visible in old Per,     -- but is not visible any more.     perOld <- getPerFid lid-    perceptionA lid outPA inPA+    perceptionA lid outPer inPer     perNew <- getPerFid lid     s <- getState     fid <- getsClient sside@@ -111,12 +146,13 @@     -- and keep only those where seenAtomicCli is True; this is even     -- cheaper than repeated posToActor (until it's optimized).     let outFov = totalVisible perOld ES.\\ totalVisible perNew-        outPrio = mapMaybe (\p -> posToActor p lid s) $ ES.elems outFov-        fActor aid =-          let b = getActorBody aid s-          in if bfid b == fid  -- optimization; precludes DominateActorA-             then Nothing-             else Just $ LoseActorA aid b (getActorItem aid s)+        outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov+        fActor ((aid, b), ais) =+          -- TODO: instead of bproj, check that actor sees himself.+          if not (bproj b) && bfid b == fid+          then Nothing  -- optimization: the actor is soon lost anyway,+                        -- e.g., via DominateActorA, so don't bother+          else Just $ LoseActorA aid b ais         outActor = mapMaybe fActor outPrio     -- Wipe out remembered items on tiles that now came into view.     Level{lfloor, lsmell} <- getLevel lid@@ -146,18 +182,29 @@     assert (allB (not . seenOld) psItemSmell) skip     -- Verify that we forget only currently seen items and smell.     assert (allB seenNew psItemSmell) skip-    return $ cmd : outActor ++ inItem ++ inSmell+    return $! cmd : outActor ++ inItem ++ inSmell   _ -> return [cmd] +deleteSmell :: MonadClient m => ActorId -> Point -> m [CmdAtomic]+deleteSmell aid pos = do+  Kind.COps{coactor = Kind.Ops{okind}} <- getsState scops+  b <- getsState $ getActorBody aid+  let canSmell = asmell $ okind $ bkind b+  if canSmell then do+    lvl <- getLevel $ blid b+    let msml = EM.lookup pos $ lsmell lvl+    return $+      maybe [] (\sml -> [AlterSmellA (blid b) pos (Just sml) Nothing]) msml+  else return []+ -- | Effect of atomic actions on client state is calculated -- in the global state before the command is executed.--- Clients keep a subset of atomic commands sent by the server--- and add their own. The result of this function is the list of commands--- kept for each command received. cmdAtomicSemCli :: MonadClient m => CmdAtomic -> m () cmdAtomicSemCli cmd = case cmd of-  DestroyActorA aid _ _ -> destroyActorA aid-  LoseActorA aid _ _ -> destroyActorA aid+  CreateActorA aid body _ -> createActorA aid body+  DestroyActorA aid b _ -> destroyActorA aid b True+  SpotActorA aid body _ -> createActorA aid body+  LoseActorA aid b _ -> destroyActorA aid b False   LeadFactionA fid source target -> do     side <- getsClient sside     when (side == fid) $ do@@ -168,66 +215,66 @@       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-  PerceptionA lid outPA inPA -> perceptionA lid outPA inPA-  RestartA _ sdisco sfper s sdebugCli _ -> do-    side <- getsClient sside-    let fact = sfactionD s EM.! side+  PerceptionA lid outPer inPer -> perceptionA lid outPer inPer+  RestartA side sdisco sfper _ sdebugCli _ -> do     shistory <- getsClient shistory     sconfigUI <- getsClient sconfigUI     isAI <- getsClient sisAI     let cli = defStateClient shistory sconfigUI side isAI     putClient cli { sdisco                   , sfper-                  , _sleader = gleader fact-                  , sundo = [CmdAtomic cmd]-                  , sdebugCli}+                  -- , sundo = [CmdAtomic cmd]+                  , scurDifficulty = sdifficultyCli sdebugCli+                  , sdebugCli }   ResumeA _fid sfper -> modifyClient $ \cli -> cli {sfper}   KillExitA _fid -> killExitA   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}+createActorA :: MonadClient m => ActorId -> Actor -> m ()+createActorA aid _b = do+  let affect tgt = case tgt of+        TEnemyPos a _ _ permit | a == aid -> TEnemy a permit+        _ -> tgt+      affect3 (tgt, mpath) = case tgt of+        TEnemyPos a _ _ permit | a == aid -> (TEnemy a permit, Nothing)+        _ -> (tgt, mpath)+  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}+  modifyClient $ \cli -> cli {scursor = affect $ scursor cli} -perceptionA :: MonadClient m => LevelId -> PerActor -> PerActor -> m ()-perceptionA lid outPA inPA = do-  cops <- getsState scops-  s <- getState+destroyActorA :: MonadClient m => ActorId -> Actor -> Bool -> m ()+destroyActorA aid b destroy = do+  when destroy $ modifyClient $ updateTarget aid (const Nothing)  -- gc+  modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}  -- gc+  let affect tgt = case tgt of+        TEnemy a permit | a == aid -> TEnemyPos a (blid b) (bpos b) permit+          -- Don't consider @destroy@, because even if actor dead, it makes+          -- sense to go to last known location to loot or find others.+        _ -> tgt+      affect3 (tgt, mpath) = (affect tgt, mpath)  -- old path always good+  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}+  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}++perceptionA :: MonadClient m => LevelId -> Perception -> Perception -> m ()+perceptionA lid outPer inPer = do   -- Clients can't compute FOV on their own, because they don't know   -- if unknown tiles are clear or not. Server would need to send   -- info about properties of unknown tiles, which complicates   -- and makes heavier the most bulky data set in the game: tile maps.-  -- Note we assume, but do not check that @outPA@ is contained-  -- in current perception and @inPA@ has no common part with it.+  -- Note we assume, but do not check that @outPer@ is contained+  -- in current perception and @inPer@ has no common part with it.   -- It would make the already very costly operation even more expensive.   perOld <- getPerFid lid   -- Check if new perception is already set in @cmdAtomicFilterCli@   -- or if we are doing undo/redo, which does not involve filtering.   -- The data structure is strict, so the cheap check can't be any simpler.-  let interHead [] = Nothing-      interHead ((aid, vis) : _) =-        Just $ pvisible vis `ES.intersection`-                 maybe ES.empty pvisible (EM.lookup aid (perActor perOld))-      unset = maybe False ES.null (interHead (EM.assocs inPA))-              || maybe False (not . ES.null) (interHead (EM.assocs outPA))+  let interAlready per =+        Just $ totalVisible per `ES.intersection` totalVisible perOld+      unset = maybe False ES.null (interAlready inPer)+              || maybe False (not . ES.null) (interAlready outPer)   when unset $ do-    let dummyToPer Perception{perActor} = Perception-          { perActor-          , ptotal = PerceptionVisible-                     $ ES.unions $ map pvisible $ EM.elems perActor-          , psmell = smellFromActors cops s perActor }-        paToDummy perActor = Perception-          { perActor-          , ptotal = PerceptionVisible ES.empty-          , psmell = PerceptionVisible ES.empty }-        outPer = paToDummy outPA-        inPer = paToDummy inPA-        adj Nothing = assert `failure` "no perception to alter" `twith` lid-        adj (Just per) = Just $ dummyToPer $ addPer (diffPer per outPer) inPer+    let adj Nothing = assert `failure` "no perception to alter" `twith` lid+        adj (Just per) = Just $ addPer (diffPer per outPer) inPer         f = EM.alter adj lid     modifyClient $ \cli -> cli {sfper = f (sfper cli)} @@ -268,23 +315,43 @@ -- the client state is modified by the command. drawCmdAtomicUI :: MonadClientUI m => Bool -> CmdAtomic -> m () drawCmdAtomicUI verbose cmd = case cmd of-  CreateActorA aid body _ -> do-    when verbose $ actorVerbMU aid body "appear"-    lookAtMove aid-  DestroyActorA aid body _ ->+  CreateActorA aid body _ -> createActorUI aid body verbose "appear"+  DestroyActorA aid body _ -> do     destroyActorUI aid body "die" "be destroyed" verbose+    side <- getsClient sside+    when (bfid body == side && not (bproj body)) stopPlayBack   CreateItemA _ item k _ -> itemVerbMU item k "drop to the ground"   DestroyItemA _ item k _ -> itemVerbMU item k "disappear"+  SpotActorA aid body _ -> createActorUI aid body verbose "be spotted"   LoseActorA aid body _ ->     destroyActorUI aid body "be missing in action" "be lost" verbose+  SpotItemA _ item k c -> do+    scursorOld <- getsClient scursor+    case scursorOld of+      TEnemy{} -> return ()  -- probably too important to overwrite+      TEnemyPos{} -> return ()+      _ -> do+        (lid, p) <- posOfContainer c+        modifyClient $ \cli -> cli {scursor = TPoint lid p}+        stopPlayBack+        -- TODO: perhaps don't spam for already seen items; very hard to do+        itemVerbMU item k "be spotted"   MoveActorA aid _ _ -> lookAtMove aid   WaitActorA aid _ _| verbose -> aVerbMU aid "wait"   DisplaceActorA source target -> displaceActorUI source target   MoveItemA iid k c1 c2 -> moveItemUI verbose iid k c1 c2-  HealActorA aid n | verbose ->-    aVerbMU aid $ MU.Text $ if n > 0-                            then "heal"  <+> showT n <> "HP"-                            else "be about to lose" <+> showT n <> "HP"+  HealActorA aid n -> do+    when verbose $+      aVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")+                              <+> tshow (abs n) <> "HP"+    mleader <- getsClient _sleader+    when (Just aid == mleader) $ do+      Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops+      b <- getsState $ getActorBody aid+      let ActorKind{ahp} = okind $ bkind b+      when (bhp b == maxDice ahp) $ do+        actorVerbMU aid b "heal fully"+        stopPlayBack   HasteActorA aid delta ->     aVerbMU aid $ if delta > speedZero                   then "speed up"@@ -313,13 +380,18 @@   QuitFactionA fid mbody _ toSt -> quitFactionUI fid mbody toSt   AlterTileA{} | verbose ->     return ()  -- TODO: door opens-  SearchTileA aid _ fromTile toTile -> do+  SearchTileA aid p fromTile toTile -> do     Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops+    b <- getsState $ getActorBody aid+    lvl <- getLevel $ blid b     subject <- partAidLeader aid-    let verb = "reveal that the"+    let t = lvl `at` p+        verb | t == toTile = "confirm"+             | otherwise = "reveal"         subject2 = MU.Text $ tname $ okind fromTile         verb2 = "be"     let msg = makeSentence [ MU.SubjectVerbSg subject verb+                           , "that the"                            , MU.SubjectVerbSg subject2 verb2                            , "a hidden"                            , MU.Text $ tname $ okind toTile ]@@ -357,8 +429,7 @@                                     "look like an ordinary"           , objUnkown1, objUnkown2 ]     msgAdd msg-  RestartA _ _ _ _ _ t ->-    msgAdd $ "New game started in" <+> t <+> "mode."+  RestartA _ _ _ _ _ t -> msgAdd $ "New game started in" <+> t <+> "mode."   SaveBkpA | verbose -> msgAdd "Saving backup."   MsgAllA msg -> msgAdd msg   _ -> return ()@@ -371,8 +442,16 @@   when (not (bproj body)         && bfid body == side         && isNothing tgtMode) $ do  -- targeting does a more extensive look-    lookMsg <- lookAt False True (bpos body) aid ""+    lookMsg <- lookAt False "" True (bpos body) aid ""     msgAdd lookMsg+  fact <- getsState $ (EM.! bfid body) . sfactionD+  Level{lxsize, lysize} <- getsState $ (EM.! blid body) . sdungeon+  if side == bfid body then do+    foes <- getsState $ actorList (isAtWar fact) (blid body)+    when (foesAdjacent lxsize lysize (bpos body) foes) stopPlayBack+  else when (isAtWar fact side) $ do+    foes <- getsState $ actorNotProjList (== side) (blid body)+    when (foesAdjacent lxsize lysize (bpos body) foes) stopPlayBack  -- | Sentences such as \"Dog barks loudly.\". actorVerbMU :: MonadClientUI m => ActorId -> Actor -> MU.Part -> m ()@@ -409,6 +488,23 @@                          , partItemWs coitem disco k item ]   msgAdd msg +-- TODO: "XXX spots YYY"? or blink or show the changed cursor?+createActorUI :: MonadClientUI m => ActorId -> Actor -> Bool -> MU.Part -> m ()+createActorUI aid body verbose verb = do+  side <- getsClient sside+  when (verbose || bfid body /= side) $ actorVerbMU aid body verb+  when (bfid body /= side) $ do+    fact <- getsState $ (EM.! bfid body) . sfactionD+    when (not (bproj body) && isAtWar fact side) $ do+      -- Target even if nobody can aim at the enemy. Let's home in on him+      -- and then we can aim or melee. We set permit to False, because it's+      -- technically very hard to check aimability here, because we are+      -- in-between turns and, e.g., leader's move has not yet been taken+      -- into account.+      modifyClient $ \cli -> cli {scursor = TEnemy aid False}+    stopPlayBack+  lookAtMove aid+ destroyActorUI :: MonadClientUI m                => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m () destroyActorUI aid body verb verboseVerb verbose = do@@ -457,18 +553,16 @@ quitFactionUI :: MonadClientUI m               => FactionId -> Maybe Actor -> Maybe Status -> m () quitFactionUI fid mbody toSt = do-  Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops-  factionD <- getsState sfactionD-  let fact = factionD EM.! fid-      fidName = MU.Text $ gname fact+  cops@Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops+  fact <- getsState $ (EM.! fid) . sfactionD+  let fidName = MU.Text $ gname fact+      horror = isHorrorFact cops fact   side <- getsClient sside-  spawn <- getsState $ isSpawnFaction fid-  summon <- getsState $ isSummonFaction fid   let msgIfSide _ | fid /= side = Nothing       msgIfSide s = Just s       (startingPart, partingPart) = case toSt of-        _ | summon && not spawn ->-          (Nothing, Nothing)  -- Ignore summoned actors factions.+        _ | horror ->+          (Nothing, Nothing)  -- Ignore summoned actors' factions.         Just Status{stOutcome=Killed} ->           ( Just "be eliminated"           , msgIfSide "Let's hope another party can save the day!" )@@ -514,7 +608,7 @@       startingSlide <- promptToSlideshow moreMsg       recordHistory  -- we are going to exit or restart, so record       itemSlides <--        if EM.null bag then return Monoid.mempty+        if EM.null bag then return mempty         else do           io <- floorItemOverlay bag           overlayToSlideshow itemMsg io@@ -525,10 +619,10 @@       shutdownSlide <- promptToSlideshow pp       -- TODO: First ESC cancels items display.       void $ getInitConfirms ColorFull []-        $ startingSlide Monoid.<> itemSlides+           $ startingSlide <> itemSlides       -- TODO: Second ESC cancels high score and parting message display.       -- The last slide stays onscreen during shutdown, etc.-          Monoid.<> scoreSlides Monoid.<> partingSlide Monoid.<> shutdownSlide+          <> scoreSlides <> partingSlide <> shutdownSlide     _ -> return ()  -- * SfxAtomicUI
Game/LambdaHack/Client/Binding.hs view
@@ -1,68 +1,60 @@--- | Generic binding of keys to commands, procesing macros,--- printing command help. No operation in this module--- involves the 'State' or 'Action' type.+-- | Binding of keys to commands.+-- No operation in this module involves the 'State' or 'Action' type. module Game.LambdaHack.Client.Binding   ( Binding(..), stdBinding, keyHelp,   ) where  import Control.Arrow (second) import qualified Data.Char as Char-import qualified Data.List as L+import Data.List import qualified Data.Map.Strict as M-import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Tuple (swap)  import Game.LambdaHack.Client.Config-import Game.LambdaHack.Client.HumanCmd+import Game.LambdaHack.Common.HumanCmd import qualified Game.LambdaHack.Common.Key as K+import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Content.RuleKind  -- | 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+  { bcmdMap  :: !(M.Map K.KM (Text, CmdCategory, HumanCmd))+                                        -- ^ binding of keys to commands+  , bcmdList :: ![(K.KM, (Text, CmdCategory, HumanCmd))]+                                        -- ^ the properly ordered list+                                        --   of commands for the help menu+  , brevMap  :: !(M.Map HumanCmd K.KM)  -- ^ and from commands to their keys   }  -- | Binding of keys to movement and other standard commands, -- as well as commands defined in the config file.-stdBinding :: ConfigUI  -- ^ game config-           -> Binding   -- ^ concrete binding-stdBinding !config@ConfigUI{configMacros} =-  let kmacro = M.fromList configMacros+stdBinding :: Kind.Ops RuleKind  -- ^ default game rules+           -> ConfigUI           -- ^ game config+           -> Binding            -- ^ concrete binding+stdBinding corule !ConfigUI{configCommands} =+  let stdRuleset = Kind.stdRuleset corule       heroSelect k = ( K.KM { key=K.Char (Char.intToDigit k)                             , modifier=K.NoModifier }-                     , SelectHero k )-      cmdList =-        configCommands config-        ++ K.moveBinding Move Run+                     , (CmdMeta, PickLeader k) )+      cmdWithHelp = rhumanCommands stdRuleset ++ configCommands+      cmdAll =+        cmdWithHelp+        ++ [(K.mkKM "KP_Begin", (CmdMove, Wait))]+        ++ K.moveBinding (\v -> (CmdMove, Move v)) (\v -> (CmdMove, Run v))         ++ fmap heroSelect [0..9]-      mkDescribed cmd = (cmdDescription cmd, noRemoteHumanCmd cmd, cmd)-      mkCommand = second mkDescribed-      semList = L.map mkCommand cmdList+      mkDescribed (cat, cmd) = (cmdDescription cmd, cat, cmd)   in Binding-  { kcmd = M.fromList semList-  , kmacro-  , kmajor = L.map fst $ L.filter (majorHumanCmd . snd) cmdList-  , kminor = L.map fst $ L.filter (minorHumanCmd . snd) cmdList-  , krevMap = M.fromList $ map swap cmdList+  { bcmdMap = M.fromList $ map (second mkDescribed) cmdAll+  , bcmdList = map (second mkDescribed) cmdWithHelp+  , brevMap = M.fromList $ map swap $ map (second snd) cmdAll   } -coImage :: M.Map K.KM K.KM -> K.KM -> [K.KM]-coImage kmacro k =-  let domain = M.keysSet kmacro-  in if k `S.member` domain-     then []-     else k : [ from | (from, to) <- M.assocs kmacro, to == k ]- -- | Produce a set of help screens from the key bindings. keyHelp :: Binding -> Slideshow-keyHelp Binding{kcmd, kmacro, kmajor, kminor} =+keyHelp Binding{bcmdList} =   let     movBlurb =       [ "Move throughout the level with numerical keypad or"@@ -74,45 +66,47 @@       , "                /|\\            /|\\"       , "               1 2 3          b j n"       , ""-      ,"Run ahead until anything disturbs you, with SHIFT (or CTRL) and a key."+      , "Run ahead, until anything disturbs you, with SHIFT (or CTRL) and a key."       , "Press keypad '5' or '.' to wait a turn, bracing for blows next turn."       , "In targeting mode the same keys move the targeting cursor."       , ""       , "Search, open and attack, by bumping into walls, doors and enemies."       , ""-      , "Press SPACE to see the next page, with the list of major commands."+      , "Press SPACE to see detailed command descriptions."       ]-    majorBlurb =+    categoryBlurb =       [ ""-      , "Commands marked with * take time and are blocked on remote levels."-      , "Press SPACE to see the next page, with the list of minor commands."+      , "Press SPACE to see the next page of command descriptions."       ]-    minorBlurb =+    lastBlurb =       [ ""       , "For more playing instructions see file PLAYING.md."       , "Press SPACE to clear the messages and see the map again."       ]-    fmt k h = T.replicate 16 " "-              <> T.justifyLeft 15 ' ' k-              <> T.justifyLeft 41 ' ' h-    fmts s  = " " <> T.justifyLeft 71 ' ' s-    blank   = fmt "" ""-    mov     = map fmts movBlurb-    major   = map fmts majorBlurb-    minor   = map fmts minorBlurb+    fmt k h = T.justifyRight 72 ' '+              $ T.justifyLeft 15 ' ' k+                <> T.justifyLeft 41 ' ' h+    fmts s = " " <> T.justifyLeft 71 ' ' s+    movText = map fmts movBlurb+    categoryText = map fmts categoryBlurb+    lastText = map fmts lastBlurb     keyCaption = fmt "keys" "command"-    disp k  = T.concat $ map K.showKM $ coImage kmacro k-    keys l  = [ fmt (disp k) (h <> if timed then "*" else "")-              | (k, (h, timed, _)) <- l, h /= "" ]-    (kcMajor, kcRest) =-      L.partition ((`elem` kmajor) . fst) (M.toAscList kcmd)-    (kcMinor, _) =-      L.partition ((`elem` kminor) . fst) kcRest-  in toSlideshow-    [ ["Basic keys. [press SPACE to advance]"] ++ [blank]-      ++ mov ++ [moreMsg]-    , ["Basic keys. [press SPACE to advance]"] ++ [blank]-      ++ [keyCaption] ++ keys kcMajor ++ major ++ [moreMsg]-    , ["Basic keys."] ++ [blank]-      ++ [keyCaption] ++ keys kcMinor ++ minor+    coImage :: K.KM -> [K.KM]+    coImage k = k : sort [ from+                         | (from, (_, _, Macro _ [to])) <- bcmdList+                         , K.mkKM to == k ]+    disp k = T.concat $ intersperse " and " $ map K.showKM $ coImage k+    keys cat = [ fmt (disp k) h+               | (k, (h, cat', _)) <- bcmdList, cat == cat', h /= "" ]+  in toSlideshow True+    [ ["Basic keys. [press SPACE to advance]"] ++ [""]+      ++ movText ++ [moreMsg]+    , [categoryDescription CmdMove <> ". [press SPACE to advance]"] ++ [""]+      ++ [keyCaption] ++ keys CmdMove ++ categoryText ++ [moreMsg]+    , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""]+      ++ [keyCaption] ++ keys CmdItem ++ categoryText ++ [moreMsg]+    , [categoryDescription CmdTgt <> ". [press SPACE to advance]"] ++ [""]+      ++ [keyCaption] ++ keys CmdTgt ++ categoryText ++ [moreMsg]+    , [categoryDescription CmdMeta <> "."] ++ [""]+      ++ [keyCaption] ++ keys CmdMeta ++ lastText     ]
Game/LambdaHack/Client/ClientSem.hs view
@@ -1,255 +1,325 @@ -- | Semantics of most 'CmdClientAI' client commands. module Game.LambdaHack.Client.ClientSem where +import Control.Exception.Assert.Sugar import Control.Monad-import Control.Monad.Writer.Strict (runWriterT) import qualified Data.EnumMap.Strict as EM+import Data.List import qualified Data.Map.Strict as M import Data.Maybe+import Data.Ord import qualified Data.Text as T  import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.Binding+import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.Draw-import Game.LambdaHack.Client.HumanCmd-import Game.LambdaHack.Client.HumanLocal import Game.LambdaHack.Client.HumanSem import Game.LambdaHack.Client.RunAction import Game.LambdaHack.Client.State import Game.LambdaHack.Client.Strategy import Game.LambdaHack.Client.StrategyAction-import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.HumanCmd 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 qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.RuleKind-import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -queryAI :: MonadClient m => ActorId -> m CmdSerTakeTime+queryAI :: MonadClient m => ActorId -> m CmdTakeTimeSer queryAI oldAid = do-  Kind.COps{cofaction=Kind.Ops{okind}, corule} <- getsState scops-  side <- getsClient sside-  fact <- getsState $ \s -> sfactionD s EM.! side-  let abilityLeader = fAbilityLeader $ okind $ gkind fact+  Kind.COps{cotile, cofaction=Kind.Ops{okind}} <- getsState scops+  oldBody <- getsState $ getActorBody oldAid+  let side = bfid oldBody+      arena = blid oldBody+  fact <- getsState $ (EM.! side) . sfactionD+  lvl <- getLevel arena+  let leaderStuck = waitedLastTurn oldBody+      t = lvl `at` bpos oldBody+      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: 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` abilityOther-    then queryAIPick oldAid-    else do-      fper <- getsClient sfper-      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-      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: 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-          let countMinFoeDist (aid, b) =-                let distB = chessDist lxsize (bpos b)-                    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+  ours <- getsState $ actorNotProjAssocs (== side) arena+  let pickOld = do+        void $ refreshTarget oldAid (oldAid, oldBody)+        queryAIPick (oldAid, oldBody)+  case ours of+    _ | -- Keep the leader: only a leader is allowed to pick another leader.+        mleader /= Just oldAid+        -- Keep the leader: abilities are the same (we assume leader can do+        -- at least as much as others). TODO: check not accurate,+        -- instead define 'movesThisTurn' and use elsehwere.+        || abilityLeader == abilityOther+        -- Keep the leader: spawners can't change leaders themselves.+        || isSpawnFact fact+        -- Keep the leader: he is on stairs and not stuck+        -- and we don't want to clog stairs or get pushed to another level.+        || not leaderStuck && Tile.isStair cotile t+      -> pickOld+    [] -> assert `failure` (oldAid, oldBody)+    [_] -> pickOld  -- Keep the leader: he is alone on the level.+    (captain, captainBody) : (sergeant, sergeantBody) : _ -> do+      -- At this point we almost forget who the old leader was+      -- and treat all party actors the same, eliminating candidates+      -- until we can't distinguish them any more, at which point we prefer+      -- the old leader, if he is among the best candidates+      -- (to make the AI appear more human-like to easier to observe).+      -- TODO: this also takes melee into account, not shooting.+      oursTgt <- fmap catMaybes $ mapM (refreshTarget oldAid) ours+      let targetTEnemy (_, (TEnemy{}, _)) = True+          targetTEnemy _ = False+          (oursTEnemy, oursOther) = partition targetTEnemy oursTgt+          -- These are not necessarily stuck (perhaps can go around),+          -- but their current path is blocked by friends.+          targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) =+            let next = case path of+                  [] -> assert `failure` our+                  [_goal] -> Nothing+                  _ : q : _ -> Just q+            in any ((== next) . Just . bpos . snd) ours+-- TODO: stuck actors are picked while others close could approach an enemy;+-- we should detect stuck actors (or one-sided stuck)+-- so far we only detect blocked and only in Other mode+--             && not (aid == oldAid && waitedLastTurn b time)  -- not stuck+-- this only prevents staying stuck+          (oursBlocked, oursPos) = partition targetBlocked oursOther+          valueOurs :: ((ActorId, Actor), (Target, PathEtc))+                    -> (Int, Int, Bool)+          valueOurs our@((aid, b), (TEnemy{}, (_, (_, d)))) =+            -- TODO: take weapon, walk and fight speed, etc. into account+            ( d + if targetBlocked our then 2 else 0  -- possible delay, hacky+            , - 10 * (bhp b `div` 10)+            , aid /= oldAid )+          valueOurs ((aid, b), (_tgt, (_path, (goal, d)))) =+            -- Keep proper formation, not too dense, not to sparse.+            let -- TODO: vary the parameters according to the stage of game,+                -- enough equipment or not, game mode, level map, etc.+                minSpread = 7+                maxSpread = 12 * 2+                dcaptain p =+                  chessDistVector $ displacement p (bpos captainBody)+                dsergeant p =+                  chessDistVector $ displacement p (bpos sergeantBody)+                minDist | aid == captain = dsergeant (bpos b)+                        | aid == sergeant = dcaptain (bpos b)+                        | otherwise = dsergeant (bpos b)+                                      `min` dcaptain (bpos b)+                pDist p = dcaptain p + dsergeant p+                sumDist = pDist (bpos b)+                -- Positive, if the goal gets us closer to the party.+                diffDist = sumDist - pDist goal+                minCoeff | minDist < minSpread =+                  (minDist - minSpread) `div` 3+                  - if aid == oldAid then 3 else 0+                         | otherwise = 0+                explorationValue = diffDist * (sumDist `div` 4)+-- TODO: this half is not yet ready:+-- instead spread targets between actors; moving many actors+-- to a single target and stopping and starting them+-- is very wasteful; also, pick targets not closest to the actor in hand,+-- but to the sum of captain and sergant or something+                sumCoeff | sumDist > maxSpread = - explorationValue+                         | otherwise = 0+            in ( if d == 0 then d+                 else max 1 $ minCoeff + if d < 10+                                         then 3 + d `div` 4+                                         else 9 + d `div` 10+               , sumCoeff+               , aid /= oldAid )+          sortOurs = sortBy $ comparing valueOurs+          goodGeneric _our@((aid, b), (_tgt, _pathEtc)) =+            bhp b > 0  -- not incapacitated+            && not (aid == oldAid && waitedLastTurn b)  -- not stuck+          goodTEnemy our@((_aid, b), (_tgt, (_path, (goal, _d)))) =+            not (adjacent (bpos b) goal) -- not in melee range already+            && goodGeneric our+          oursTEnemyGood = filter goodTEnemy oursTEnemy+          oursPosGood = filter goodGeneric oursPos+          oursBlockedGood = filter goodGeneric oursBlocked+          candidates = sortOurs oursTEnemyGood+                       ++ sortOurs oursPosGood+                       ++ sortOurs oursBlockedGood+      case candidates of+        [] -> queryAIPick (oldAid, oldBody)+        c : _ -> do+          let best = takeWhile ((== valueOurs c) . valueOurs) candidates+              freq = uniformFreq "candidates for AI leader" best+          ((aid, b), _) <- rndToAction $ frequency freq           s <- getState           modifyClient $ updateLeader aid s-          queryAIPick aid+          queryAIPick (aid, b) -queryAIPick :: MonadClient m => ActorId -> m CmdSerTakeTime-queryAIPick aid = do-  Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops+refreshTarget :: MonadClient m+              => ActorId -> (ActorId, Actor)+              -> m (Maybe ((ActorId, Actor), (Target, PathEtc)))+refreshTarget oldLeader (aid, body) = do   side <- getsClient sside-  body <- getsState $ getActorBody aid+  assert (bfid body == side `blame` "AI tries to move an enemy actor"+                            `twith` (aid, body, side)) skip+  assert (not (bproj body) `blame` "AI gets to manually move its projectiles"+                           `twith` (aid, body, side)) skip+  stratTarget <- targetStrategy oldLeader aid+  tgtMPath <-+    if nullStrategy stratTarget then+      -- No sensible target, wipe out the old one  .+      return Nothing+    else do+      -- Choose a target from those proposed by AI for the actor.+      (tgt, path) <- rndToAction $ frequency $ bestVariant stratTarget+      return $ Just (tgt, Just path)+  let _debug = T.unpack+          $ "\nHandleAI symbol:"    <+> tshow (bsymbol body)+          <> ", aid:"               <+> tshow aid+          <> ", pos:"               <+> tshow (bpos body)+          <> "\nHandleAI starget:"  <+> tshow stratTarget+          <> "\nHandleAI target:"   <+> tshow tgtMPath+--  trace _debug skip+  modifyClient $ \cli ->+    cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)}+  return $! case tgtMPath of+    Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc))+    _ -> Nothing++queryAIPick :: MonadClient m => (ActorId, Actor) -> m CmdTakeTimeSer+queryAIPick (aid, body) = do+  side <- getsClient sside   assert (bfid body == side `blame` "AI tries to move enemy actor"                             `twith` (aid, bfid body, side)) skip-  mleader <- getsClient _sleader-  fact <- getsState $ (EM.! bfid body) . sfactionD-  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)-          <> "\nHandleAI starget:"  <+> showT stratTarget-          <> "\nHandleAI target:"   <+> showT btarget---    trace _debug skip-    modifyClient $ updateTarget aid (const btarget)-  stratAction <- actionStrategy aid factionAbilities+  assert (not (bproj body) `blame` "AI gets to manually move its projectiles"+                           `twith` (aid, bfid body, side)) skip+  stratAction <- actionStrategy aid   -- 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---  trace _debug skip-  return action+  rndToAction $ frequency $ bestVariant stratAction  -- | Handle the move of a UI player.-queryUI :: (MonadClientAbort m, MonadClientUI m) => ActorId -> m CmdSer+queryUI :: 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.+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  -- When running, stop if disturbed. If not running, let the human+  -- player issue commands, until any command takes time.   leader <- getLeaderUI   assert (leader == aid `blame` "player moves not his leader"                         `twith` (leader, aid)) skip-  let inputHumanCmd msg = do-        stopRunning-        humanCommand msg-  tryWith inputHumanCmd $ do-    srunning <- getsClient srunning-    maybe abort (continueRun leader) srunning---- | Continue running in the given direction.-continueRun :: MonadClientAbort m => ActorId -> (Vector, Int) -> m CmdSer-continueRun leader dd = do-  (dir, distNew) <- continueRunDir leader dd-  modifyClient $ \cli -> cli {srunning = Just (dir, distNew)}-  -- The potential invisible actor is hit. War is started without asking.-  return $ TakeTimeSer $ MoveSer leader dir+  srunning <- getsClient srunning+  case srunning of+    Nothing -> humanCommand Nothing+    Just RunParams{runMembers} | isSpawnFact fact && runMembers /= [aid] -> do+      stopRunning+      ConfigUI{configRunStopMsgs} <- getsClient sconfigUI+      let msg = if configRunStopMsgs+                then Just $ "Run stop: spawner leader change"+                else Nothing+      humanCommand msg+    Just runParams -> do+      runOutcome <- continueRun runParams+      case runOutcome of+        Left stopMsg -> do+          stopRunning+          ConfigUI{configRunStopMsgs} <- getsClient sconfigUI+          let msg = if configRunStopMsgs+                    then Just $ "Run stop:" <+> stopMsg+                    else Nothing+          humanCommand msg+        Right (paramNew, runCmd) -> do+          modifyClient $ \cli -> cli {srunning = Just paramNew}+          return $! CmdTakeTimeSer runCmd  -- | Determine and process the next human player command. The argument is--- the last abort message due to running, if any.-humanCommand :: forall m. (MonadClientAbort m, MonadClientUI m)-             => Msg+-- the last stop message due to running, if any.+humanCommand :: forall m. MonadClientUI m+             => Maybe Msg              -> m CmdSer-humanCommand msgRunAbort = do-  let loop :: Overlay -> m CmdSer-      loop overlay = do-        km <- getKeyOverlayCommand overlay+humanCommand msgRunStop = do+  -- For human UI we invalidate whole @sbfsD@ at the start of each+  -- UI player input, which is an overkill, but doesn't affects+  -- screensavers, because they are UI, but not human.+  modifyClient $ \cli -> cli {sbfsD = EM.empty}+  let loop :: Maybe (Bool, Overlay) -> m CmdSer+      loop mover = do+        (lastBlank, over) <- case mover of+          Nothing -> do+            -- Display current state if no slideshow or if interrupted.+            modifyClient $ \cli -> cli {slastKey = Nothing}+            sli <- promptToSlideshow ""+            return (False, head . snd $! slideshow sli)+          Just bLast ->+            -- (Re-)display the last slide while waiting for the next key.+            return bLast+        (seqCurrent, seqPrevious, k) <- getsClient slastRecord+        case k of+          0 -> do+            let slastRecord = ([], seqCurrent, 0)+            modifyClient $ \cli -> cli {slastRecord}+          _ -> do+            let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1)+            modifyClient $ \cli -> cli {slastRecord}+        km <- getKeyOverlayCommand lastBlank over         -- Messages shown, so update history and reset current report.         recordHistory-        -- On abort, just reset state and call loop again below.-        -- Each abort that gets this far generates a slide to be shown.-        (mcmdS, slides) <- runWriterT $ tryWithSlide (return Nothing) $ do+        abortOrCmd <- do           -- Look up the key.-          Binding{kcmd} <- askBinding-          case M.lookup km kcmd of+          Binding{bcmdMap} <- askBinding+          case M.lookup km bcmdMap of             Just (_, _, cmd) -> do               -- Query and clear the last command key.               lastKey <- getsClient slastKey-              -- TODO: perhaps replace slastKey-              -- with test 'kmNext == km'-              -- or an extra arg to 'loop'.-              -- Depends on whether slastKey-              -- is needed in other parts of code.-              modifyClient (\st -> st {slastKey = Just km})-              cmdHumanSem $ if Just km == lastKey-                            then Clear-                            else cmd+              stgtMode <- getsClient stgtMode+              modifyClient $ \cli -> cli+                {swaitTimes = if swaitTimes cli > 0+                              then - swaitTimes cli+                              else 0}+              if Just km == lastKey+                 || km == K.escKey && isNothing stgtMode && isJust mover+                then do+                  modifyClient $ \cli -> cli {slastKey = Nothing}+                  cmdHumanSem Clear+                else do+                  modifyClient $ \cli -> cli {slastKey = Just km}+                  cmdHumanSem cmd             Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"-                       in abortWith msgKey-        -- The command was aborted or successful and if the latter,+                       in fmap Left $ promptToSlideshow msgKey+        -- The command was failed or successful and if the latter,         -- possibly took some time.-        case mcmdS of-          Just cmdS -> do-            assert (null (runSlideshow slides)-                    `blame` "some slides generated for server command"-                    `twith` slides) skip+        case abortOrCmd of+          Right cmdS -> do             -- Exit the loop and let other actors act. No next key needed             -- and no slides could have been generated.-            modifyClient (\st -> st {slastKey = Nothing})+            modifyClient $ \cli -> cli {slastKey = Nothing}+            case cmdS of+              CmdTakeTimeSer cmd ->+                modifyClient $ \cli -> cli {slastCmd = Just cmd}+              _ -> return ()             return cmdS-          Nothing -> do+          Left slides -> do             -- If no time taken, rinse and repeat.             -- Analyse the obtained slides.-            mLast <- case reverse (runSlideshow slides) of+            let (onBlank, sli) = slideshow slides+            mLast <- case reverse sli  of               [] -> return Nothing-              [sLast] -> return $ Just sLast+              [sLast] -> return $ Just (onBlank, sLast)               sls@(sLast : _) -> do                 -- Show, one by one, all slides, awaiting confirmation                 -- for all but the last one.                 -- Note: the code that generates the slides is responsible                 -- for inserting the @more@ prompt.-                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.-                modifyClient (\st -> st {slastKey = Nothing})-                sli <- promptToSlideshow ""-                loop $! head $! runSlideshow sli-              Just sLast ->-                -- (Re-)display the last slide while waiting for the next key,-                loop sLast-  sli <- promptToSlideshow msgRunAbort-  let overlayInitial = head $ runSlideshow sli-  loop overlayInitial+                go <- getInitConfirms ColorFull [km]+                      $ toSlideshow onBlank $ reverse $ map overlay sls+                return $! if go then Just (onBlank, sLast) else Nothing+            loop mLast+  case msgRunStop of+    Nothing -> loop Nothing+    Just msg -> do+      sli <- promptToSlideshow msg+      loop $ Just (False, head . snd $ slideshow sli)
Game/LambdaHack/Client/Config.hs view
@@ -4,51 +4,25 @@   ) where  import Control.DeepSeq-import Data.Binary -import Game.LambdaHack.Client.HumanCmd+import Data.Text (Text)+import Game.LambdaHack.Common.HumanCmd import qualified Game.LambdaHack.Common.Key as K  -- | Fully typed contents of the UI config file. This config -- is a part of a game client. data ConfigUI = ConfigUI   { -- commands-    configCommands   :: ![(K.KM, HumanCmd)]-    -- files-  , configAppDataDir :: !FilePath-  , configUICfgFile  :: !FilePath-  , configSavePrefix :: !String-    -- macros-  , configMacros     :: ![(K.KM, K.KM)]+    configCommands    :: ![(K.KM, (CmdCategory, HumanCmd))]+    -- hero names+  , configHeroNames   :: ![(Int, Text)]     -- ui-  , configFont       :: !String-  , configHistoryMax :: !Int-  , configMaxFps     :: !Int-  , configNoAnim     :: !Bool+  , configFont        :: !String+  , configHistoryMax  :: !Int+  , configMaxFps      :: !Int+  , configNoAnim      :: !Bool+  , configRunStopMsgs :: !Bool   }   deriving Show  instance NFData ConfigUI--instance Binary ConfigUI where-  put ConfigUI{..} = do-    put configCommands-    put configAppDataDir-    put configUICfgFile-    put configSavePrefix-    put configMacros-    put configFont-    put configHistoryMax-    put configMaxFps-    put configNoAnim-  get = do-    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
@@ -6,7 +6,7 @@  import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.List as L+import Data.List import Data.Maybe import Data.Text (Text) import qualified Data.Text as T@@ -14,10 +14,11 @@ import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor as Actor import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation (SingleFrame (..))+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Effect-import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Item as Item import qualified Game.LambdaHack.Common.Kind as Kind@@ -25,12 +26,14 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY+import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State+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.ModeKind import Game.LambdaHack.Content.TileKind  -- | Color mode for the display.@@ -39,157 +42,239 @@   | ColorBW    -- ^ black+white only  -- TODO: split up and generally rewrite.--- | Draw the whole screen: level map, status area and, at most,--- a single page overlay of text divided into lines.-draw :: ColorMode -> Kind.COps -> Perception -> LevelId -> Maybe ActorId-     -> StateClient -> State -> Overlay+-- | Draw the whole screen: level map and status area.+-- Pass at most a single page if overlay of text unchanged+-- to the frontends to display separately or overlay over map,+-- depending on the frontend.+draw :: Bool -> ColorMode -> Kind.COps -> Perception -> LevelId+     -> Maybe ActorId -> Maybe Point -> Maybe Point+     -> Maybe (PointArray.Array BfsDistance, Maybe [Point])+     -> StateClient -> State+     -> Text -> Text -> Overlay      -> SingleFrame-draw dm cops per drawnLevelId mleader-     StateClient{ stgtMode, scursor, seps, sdisco-                , smarkVision, smarkSmell, smarkSuspect }-     s overlay =-  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-      -- TODO:-      sVisBG = if smarkVision-               then \ vis visPl -> if visPl-                                   then Color.Magenta-                                   else if vis-                                        then Color.Blue-                                        else Color.defBG-               else \ _vis _visPl -> Color.defBG-      wealth = case mleader of-        Nothing -> 0-        Just leader -> snd $ calculateTotal (getActorBody leader s) s-      bl = case (scursor, mleader) of+draw sfBlank dm cops per drawnLevelId mleader cursorPos tgtPos bfsmpathRaw+     cli@StateClient{ stgtMode, seps, sdisco, sexplored+                    , smarkVision, smarkSmell, smarkSuspect, swaitTimes } s+     cursorDesc targetDesc sfTop =+  let Kind.COps{cotile=cotile@Kind.Ops{okind=tokind, ouniqGroup}} = cops+      (lvl@Level{lxsize, lysize, lsmell, ltime}) = sdungeon s EM.! drawnLevelId+      (bl, blLength) = case (cursorPos, mleader) of         (Just cursor, Just leader) ->           let Actor{bpos, blid} = getActorBody leader s           in if blid /= drawnLevelId-             then []-             else fromMaybe [] $ bla lxsize lysize seps bpos cursor+             then ([cursor], 0)+             else ( fromMaybe [] $ bla lxsize lysize seps bpos cursor+                  , chessDist bpos cursor )+        _ -> ([], 0)+      mpath = maybe Nothing (\(_, mp) -> if blLength == 0+                                         then Nothing+                                         else mp) bfsmpathRaw+      actorsHere = actorAssocs (const True) drawnLevelId s+      cursorHere = find (\(_, m) -> cursorPos == Just (Actor.bpos m))+                   actorsHere+      shiftedBTrajectory = case cursorHere of+        Just (_, Actor{btrajectory = Just p, bpos = prPos}) -> trajectoryToPath prPos p         _ -> []-      dis pxy =-        let pos0 = toPoint lxsize pxy-            tile = lvl `at` pos0+      unknownId = ouniqGroup "unknown space"+      dis pos0 =+        let tile = lvl `at` pos0             tk = tokind tile             items = lvl `atI` pos0             sml = EM.findWithDefault timeZero pos0 lsmell             smlt = sml `timeAdd` timeNegate ltime             viewActor aid Actor{bsymbol, bcolor, bhp, bproj}-              | Just aid == mleader = (symbol, Color.defBG)-              | otherwise = (symbol, color)+              | Just aid == mleader = (symbol, inverseVideo)+              | otherwise = (symbol, Color.defAttr {Color.fg = bcolor})              where-              color  = bcolor               symbol | bhp <= 0 && not bproj = '%'                      | otherwise = bsymbol-            rainbow p = toEnum $ fromEnum p `rem` 14 + 1-            actorsHere = actorAssocs (const True) drawnLevelId s+            rainbow p = Color.defAttr {Color.fg =+                                         toEnum $ fromEnum p `rem` 14 + 1}             -- smarkSuspect is an optional overlay, so let's overlay it             -- over both visible and invisible tiles.-            vcolor t-              | smarkSuspect && F.Suspect `elem` tfeature t = Color.BrCyan-              | vis = tcolor t-              | otherwise = tcolor2 t-            (char, fg0) =-              case ( L.find (\ (_, m) -> pos0 == Actor.bpos m) actorsHere-                   , L.find (\ (_, m) -> scursor == Just (Actor.bpos m))-                       actorsHere ) of-                (_, actorTgt) | isJust stgtMode-                                && (L.elem pos0 bl-                                    || (case actorTgt of-                                          Just (_, Actor{ bpath=Just p-                                                        , bpos=prPos }) ->-                                            L.elem pos0 $ shiftPath prPos p-                                          _ -> False))-                    ->-                      let unknownId = ouniqGroup "unknown space"-                      in ('*', case (vis, F.Walkable `elem` tfeature tk) of-                                 _ | tile == unknownId -> Color.BrBlack-                                 (True, True)   -> Color.BrGreen-                                 (True, False)  -> Color.BrRed-                                 (False, True)  -> Color.Green-                                 (False, False) -> Color.Red)-                (Just (aid, m), _) -> viewActor aid m+            vcolor+              | smarkSuspect && Tile.isSuspect cotile tile = Color.BrCyan+              | vis = tcolor tk+              | otherwise = tcolor2 tk+            viewItem i =+              ( jsymbol i+              , Color.defAttr {Color.fg = flavourToColor $ jflavour i} )+            fgOnPathOrLine = case (vis, Tile.isWalkable cotile tile) of+              _ | tile == unknownId -> Color.BrBlack+              _ | Tile.isSuspect cotile tile -> Color.BrCyan+              (True, True)   -> Color.BrGreen+              (True, False)  -> Color.BrRed+              (False, True)  -> Color.Green+              (False, False) -> Color.Red+            atttrOnPathOrLine = if Just pos0 `elem` [cursorPos, tgtPos]+                                then inverseVideo {Color.fg = fgOnPathOrLine}+                                else Color.defAttr {Color.fg = fgOnPathOrLine}+            (char, attr0) =+              case find (\(_, m) -> pos0 == Actor.bpos m) actorsHere of+                _ | isJust stgtMode+                    && (elem pos0 bl || elem pos0 shiftedBTrajectory) ->+                  ('*', atttrOnPathOrLine)  -- line takes precedence over path+                _ | isJust stgtMode+                    && (maybe False (elem pos0) mpath) ->+                  (';', atttrOnPathOrLine)+                Just (aid, m) -> viewActor aid m                 _ | smarkSmell && smlt > timeZero ->                   (timeToDigit smellTimeout smlt, rainbow pos0)                   | otherwise ->                   case EM.keys items of-                    [] -> (tsymbol tk, vcolor tk)-                    i : _ -> Item.viewItem $ getItemBody i s+                    [] -> (tsymbol tk, Color.defAttr {Color.fg = vcolor})+                    i : _ -> viewItem $ getItemBody i s             vis = ES.member pos0 $ totalVisible per-            visPl =-              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-            reverseVideo = Color.Attr{ fg = Color.bg Color.defAttr-                                     , bg = Color.fg Color.defAttr-                                     }-            optVisually attr@Color.Attr{fg, bg} =-              if (fg == Color.defBG)-                 || (bg == Color.defFG && fg == Color.defFG)-              then reverseVideo-              else attr+            visPl = case (mleader, bfsmpathRaw) of+              (Just leader, Just (bfs, _)) ->+                 let Actor{bpos} = getActorBody leader s+                 in posAimsPos bfs bpos pos0+              _ -> False             a = case dm of                   ColorBW   -> Color.defAttr-                  ColorFull -> optVisually Color.Attr{fg = fg0, bg = bg0}-        in case over pxy of-             Just c -> Color.AttrChar Color.defAttr c-             _      -> Color.AttrChar a char-      leaderStatus = drawLeaderStatus cops s sdisco ltime mleader-      seenN = 100 * lseen `div` lclear-      seenTxt | seenN == 100 = "all"-              | otherwise = T.justifyRight 2 ' ' (showT seenN) <> "%"-      lvlN = T.justifyLeft 2 ' ' (showT $ abs ldepth)-      stats =-        T.justifyLeft 11 ' ' ("[" <> seenTxt <+> "seen]") <+>-        T.justifyLeft 9 ' ' ("$:" <+> showT wealth) <+>-        leaderStatus-      widthForDesc = lxsize - T.length stats - T.length lvlN - 3-      status = lvlN <+> T.justifyLeft widthForDesc ' ' ldesc <+> stats-      toWidth :: Int -> Text -> Text-      toWidth n x = T.take n (T.justifyLeft n ' ' x)-      fLine y =-        let f l x = let !ac = dis (PointXY (x, y)) in ac : l-        in L.foldl' f [] [lxsize-1,lxsize-2..0]-      sfLevel =  -- Fully evaluated.+                  ColorFull ->+                    if smarkVision+                    then if visPl+                         then attr0 {Color.bg = Color.Magenta}+                         else if vis+                              then attr0 {Color.bg = Color.Blue}+                              else attr0+                    else attr0+        in Color.AttrChar a char+      showN2 n = T.justifyRight 2 ' ' (tshow n)+      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      arenaStatus = drawArenaStatus (ES.member drawnLevelId sexplored) lvl+      cursorText = (if isJust stgtMode then "cursor>" else "Cursor:")+                   <+> cursorDesc+      lineText = let space = 40 - T.length cursorText - 1+                     lText | blLength == 0 = ""+                           | otherwise = "(line" <+> showN2 blLength <> ")"+                 in if T.length lText > space+                    then ""+                    else T.justifyRight space ' ' lText+      cursorStatus = addAttr $ T.justifyLeft 40 ' ' $ cursorText <+> lineText+      selectedStatus = drawSelected cli s drawnLevelId mleader+      leaderStatus = drawLeaderStatus cops s sdisco swaitTimes mleader+      targetText = "Target:" <+> targetDesc+      pathText = let space = 40 - T.length targetText - 1+                     len = case (tgtPos, bfsmpathRaw) of+                       (Just target, Just (bfs, _)) ->+                         fromMaybe 0 (accessBfs bfs target)+                       _ -> 0+                     pText | len == 0 = ""+                           | otherwise = "(path" <+> showN2 len <> ")"+                 in if T.length pText > space+                    then ""+                    else T.justifyRight space ' ' pText+      targetStatus = addAttr $ T.justifyLeft 40 ' ' $ targetText <+> pathText+      sfBottom =+        [ encodeLine $ arenaStatus ++ cursorStatus+        , encodeLine $ selectedStatus ++ leaderStatus ++ targetStatus ]+      fLine y = encodeLine $+        let f l x = let ac = dis $ Point x y in ac : l+        in foldl' f [] [lxsize-1,lxsize-2..0]+      sfLevel =  -- fully evaluated         let f l y = let !line = fLine y in line : l-        in L.foldl' f [] [lysize-1,lysize-2..0]-      sfTop = toWidth lxsize msgTop-      sfBottom = toWidth (lxsize - 1) $ fromMaybe status msgBottom+        in foldl' f [] [lysize-1,lysize-2..0]   in SingleFrame{..} -drawLeaderStatus :: Kind.COps -> State -> Discovery -> Time -> Maybe ActorId-                 -> Text-drawLeaderStatus cops s sdisco ltime mleader =-  case mleader of-    Just leader ->-      let Kind.COps{coactor=Kind.Ops{okind}} = cops-          (bitems, bracedL, ahpS, bhpS) =-            let mpl@Actor{bkind, bhp} = getActorBody leader s-                ActorKind{ahp} = okind bkind-            in (getActorItem leader s, braced mpl ltime,-                showT (maxDice ahp), showT bhp)-          damage = case Item.strongestSword cops bitems of-            Just (_, (_, sw)) ->-              case Item.jkind sdisco sw of-                Just _ ->-                  case jeffect sw of-                    Hurt dice p -> showT dice <> "+" <> showT p-                    _ -> ""-                Nothing -> "3d1"  -- TODO: ?-            Nothing -> "3d1"  -- TODO; use the item 'fist'-          -- Indicate the actor is braced (was waiting last move).-          -- It's a useful feedback for the otherwise hard to observe-          -- 'wait' command.-          braceSign | bracedL   = "{"-                    | otherwise = " "-      in T.justifyLeft 11 ' ' ("Dmg:" <+> damage) <+>-         T.justifyLeft 13 ' ' (braceSign <> "HP:" <+> bhpS-                               <+> "(" <> ahpS <> ")")-    Nothing ->-         T.justifyLeft 11 ' ' ("Dmg:" <+> "---") <+>-         T.justifyLeft 13 ' ' (" " <> "HP:" <+> "--"-                               <+> "(" <> "--" <> ")")+inverseVideo :: Color.Attr+inverseVideo = Color.Attr { Color.fg = Color.bg Color.defAttr+                          , Color.bg = Color.fg Color.defAttr }++drawArenaStatus :: Bool -> Level -> [Color.AttrChar]+drawArenaStatus explored Level{ldepth, ldesc, lseen, lclear} =+  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      seenN = 100 * lseen `div` lclear+      seenTxt | explored || seenN >= 100 = "all"+              | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%")+      lvlN = T.justifyLeft 2 ' ' (tshow $ abs ldepth)+      seenStatus = T.justifyLeft 11 ' ' ("[" <> seenTxt <+> "seen]")+  in addAttr $ lvlN <+> T.justifyLeft 25 ' ' ldesc <+> seenStatus++drawLeaderStatus :: Kind.COps -> State -> Discovery+                 -> Int -> Maybe ActorId+                 -> [Color.AttrChar]+drawLeaderStatus cops s sdisco waitTimes mleader =+  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      stats = case mleader of+        Just leader ->+          let Kind.COps{coactor=Kind.Ops{okind}} = cops+              (bitems, bracedL, ahpS, bhpS) =+                let mpl@Actor{bkind, bhp} = getActorBody leader s+                    ActorKind{ahp} = okind bkind+                in (getActorItem leader s, braced mpl,+                    tshow (maxDice ahp), tshow bhp)+              damage = case Item.strongestSword cops bitems of+                Just (_, (_, sw)) ->+                  case Item.jkind sdisco sw of+                    Just _ ->+                      case jeffect sw of+                        Hurt dice p -> tshow dice <> "+" <> tshow p+                        _ -> ""+                    Nothing -> "5d1"  -- TODO: ?+                Nothing -> "5d1"  -- TODO; use the item 'fist'+              -- Indicate the actor is braced (was waiting last move).+              -- It's a useful feedback for the otherwise hard to observe+              -- 'wait' command.+              slashes = ["|", "\\", "|", "/"]+              slashPick | bracedL =+                slashes !! (max 0 (waitTimes - 1) `mod` length slashes)+                        | otherwise = "/"+              bracePick | bracedL   = "}"+                        | otherwise = ":"+              hpText = bhpS <> slashPick <> ahpS+          in T.justifyLeft 12 ' '+               ("Dmg:" <> (if T.length damage < 8 then " " else "") <> damage)+             <+> "HP" <> bracePick <> T.justifyRight 7 ' ' hpText+             <> " "+        Nothing ->+             T.justifyLeft 12 ' ' "Dmg: ---"+             <+> T.justifyRight 10 ' ' "HP:  --/--"+             <> " "+  in addAttr stats++drawSelected :: StateClient -> State -> LevelId -> Maybe ActorId+             -> [Color.AttrChar]+drawSelected cli s drawnLevelId mleader =+  let selected = sselected cli+      viewOurs (aid, Actor{bsymbol, bcolor, bhp})+        | otherwise =+          let cattr = Color.defAttr {Color.fg = bcolor}+              sattr+               | Just aid == mleader = inverseVideo+               | ES.member aid selected =+                   -- TODO: in the future use a red rectangle instead+                   -- of background and mark them on the map, too;+                   -- also, perhaps blink all selected on the map,+                   -- when selection changes+                   if bcolor /= Color.Blue+                   then cattr {Color.bg = Color.Blue}+                   else cattr {Color.bg = Color.Magenta}+               | otherwise = cattr+          in ( (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid)+             , Color.AttrChar sattr bsymbol )+      ours = actorNotProjAssocs (== sside cli) drawnLevelId s+      maxViewed = 14+      -- Don't show anything if the only actor on the level is the leader.+      -- He's clearly highlighted on the level map, anyway.+      star = let sattr = case ES.size selected of+                   0 -> Color.defAttr {Color.fg = Color.BrBlack}+                   n | n == length ours ->+                     Color.defAttr {Color.bg = Color.Blue}+                   _ -> Color.defAttr+                 char = if length ours > maxViewed then '$' else '*'+             in Color.AttrChar sattr char+      viewed = take maxViewed $ sort $ map viewOurs ours+      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      allOurs = filter ((== sside cli) . bfid) $ EM.elems $ sactorD s+      nameN n t = T.justifyLeft n ' '+                  $ let firstWord = head $ T.words t+                    in if T.length firstWord > n then "" else firstWord+      fact = sfactionD s EM.! sside cli+      ourName n = addAttr $ nameN n $ playerName $ gplayer fact+      party = if length allOurs <= 1+              then ourName $ maxViewed + 1+              else [star] ++ map snd viewed ++ addAttr " "+                   ++ ourName (maxViewed - 1 - length viewed)+  in party ++ addAttr (T.replicate (maxViewed + 2 - length party) " ")
− Game/LambdaHack/Client/HumanCmd.hs 
@@ -1,152 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Abstract syntax human player commands.-module Game.LambdaHack.Client.HumanCmd-  ( HumanCmd(..), Trigger(..)-  , majorHumanCmd, minorHumanCmd, noRemoteHumanCmd, cmdDescription-  ) where--import Data.Binary-import Data.Text (Text)-import GHC.Generics (Generic)-import qualified NLP.Miniutter.English as MU--import Control.Exception.Assert.Sugar-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.VectorXY---- | Abstract syntax of player commands.-data HumanCmd =-    -- These usually take time.-    Move !VectorXY-  | Run !VectorXY-  | Wait-  | Pickup-  | Drop-  | Project     ![Trigger]-  | Apply       ![Trigger]-  | AlterDir    ![Trigger]-  | TriggerTile ![Trigger]-    -- These do not take time.-  | GameRestart !Text-  | GameExit-  | GameSave-    -- These do not notify the server.-  | SelectHero !Int-  | MemberCycle-  | MemberBack-  | Inventory-  | TgtFloor-  | TgtEnemy-  | TgtAscend !Int-  | EpsIncr !Bool-  | Cancel-  | Accept-  | Clear-  | History-  | MarkVision-  | MarkSmell-  | MarkSuspect-  | Help-  deriving (Show, Read, Eq, Ord, Generic)--instance Binary HumanCmd--data Trigger =-    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---- | Major commands land on the first page of command help.-majorHumanCmd :: HumanCmd -> Bool-majorHumanCmd cmd = case cmd of-  Pickup        -> True-  Drop          -> True-  Project{}     -> True-  Apply{}       -> True-  AlterDir{}    -> True-  TriggerTile{} -> True-  Inventory     -> True-  Help          -> True-  _             -> False---- | Minor commands land on the second page of command help.-minorHumanCmd :: HumanCmd -> Bool-minorHumanCmd cmd = case cmd of-  MemberCycle -> True-  MemberBack  -> True-  TgtFloor    -> True-  TgtEnemy    -> True-  TgtAscend{} -> True-  EpsIncr{}   -> True-  Cancel      -> True-  Accept      -> True---  Clear       -> True-  History     -> True-  MarkVision  -> True-  MarkSmell   -> True-  MarkSuspect -> True-  _           -> False---- | Commands that are forbidden on a remote level, because they--- would usually take time when invoked on one.--- Not that movement commands are not included, because they take time--- on normal levels, but don't take time on remote levels, that is,--- in targeting mode.-noRemoteHumanCmd :: HumanCmd -> Bool-noRemoteHumanCmd cmd = case cmd of-  Wait          -> True-  Pickup        -> True-  Drop          -> True-  Project{}     -> True-  Apply{}       -> True-  AlterDir{}    -> True-  TriggerTile{} -> True-  _             -> False---- | Description of player commands.-cmdDescription :: HumanCmd -> Text-cmdDescription cmd = case cmd of-  Move{}      -> "move"-  Run{}       -> "run"-  Wait        -> "wait"-  Pickup      -> "get an object"-  Drop        -> "drop an object"-  Project ts     -> triggerDescription ts-  Apply ts       -> triggerDescription ts-  AlterDir ts -> triggerDescription ts-  TriggerTile ts -> triggerDescription ts--  GameRestart t -> "new" <+> t <+> "game"-  GameExit    -> "save and exit"-  GameSave    -> "save game"--  SelectHero{} -> "select hero"-  MemberCycle -> "cycle among heroes on the level"-  MemberBack  -> "cycle among heroes in the dungeon"-  Inventory   -> "display inventory"-  TgtFloor    -> "target position"-  TgtEnemy    -> "target monster"-  TgtAscend k | k == 1  -> "target next shallower level"-  TgtAscend k | k >= 2  -> "target" <+> showT k    <+> "levels shallower"-  TgtAscend k | k == -1 -> "target next deeper level"-  TgtAscend k | k <= -2 -> "target" <+> showT (-k) <+> "levels deeper"-  TgtAscend _ ->-    assert `failure` "void level change when targeting" `twith` cmd-  EpsIncr True  -> "swerve targeting line"-  EpsIncr False -> "unswerve targeting line"-  Cancel      -> "cancel action"-  Accept      -> "accept choice"-  Clear       -> "clear messages"-  History     -> "display previous messages"-  MarkVision  -> "mark visible area"-  MarkSmell   -> "mark smell"-  MarkSuspect -> "mark suspect terrain"-  Help        -> "display help"--triggerDescription :: [Trigger] -> Text-triggerDescription [] = "trigger a thing"-triggerDescription (t : _) = makePhrase [verb t, MU.AW $ object t]
Game/LambdaHack/Client/HumanGlobal.hs view
@@ -2,32 +2,42 @@ -- A couple of them do not take time, the rest does. -- TODO: document module Game.LambdaHack.Client.HumanGlobal-  ( moveRunAid, displaceAid, meleeAid, waitHuman, pickupHuman, dropHuman-  , projectAid, applyHuman, alterDirHuman, triggerTileHuman+  ( -- * Commands that usually take time+    moveRunHuman, waitHuman, pickupHuman, dropHuman+  , projectHuman, applyHuman, alterDirHuman, triggerTileHuman+  , stepToTargetHuman, resendHuman+    -- * Commands that never take time   , gameRestartHuman, gameExitHuman, gameSaveHuman+    -- * Helper definitions+  , SlideOrCmd, failWith   ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES import Data.Function import Data.List import Data.Maybe+import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action+import Game.LambdaHack.Client.Config 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 import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.HumanCmd (Trigger (..)) import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Key as K import qualified Game.LambdaHack.Common.Kind as Kind@@ -39,154 +49,212 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.TileKind as TileKind -abortFailure :: MonadClientAbort m => FailureSer -> m a-abortFailure = abortWith . showFailureSer+type SlideOrCmd a = Either Slideshow a +failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a)+failWith msg = do+  modifyClient $ \cli -> cli {slastKey = Nothing}+  stopPlayBack+  assert (not $ T.null msg) $ fmap Left $ promptToSlideshow msg++failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a)+failSlides slides = do+  modifyClient $ \cli -> cli {slastKey = Nothing}+  stopPlayBack+  return $ Left slides++failSer :: MonadClientUI m => FailureSer -> m (SlideOrCmd a)+failSer = failWith . showFailureSer+ -- * Move and Run +moveRunHuman :: MonadClientUI m+             => Bool -> Vector -> m (SlideOrCmd CmdTakeTimeSer)+moveRunHuman run dir = do+  tgtMode <- getsClient stgtMode+  if isJust tgtMode then+    fmap Left $ moveCursorHuman dir (if run then 10 else 1)+  else do+    arena <- getArenaUI+    leader <- getLeaderUI+    sb <- getsState $ getActorBody leader+    fact <- getsState $ (EM.! bfid sb) . sfactionD+    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).+    tgts <- getsState $ posToActors tpos arena+    case tgts of+      [] -> do  -- move or search or alter+        -- Start running in the given direction. The first turn of running+        -- succeeds much more often than subsequent turns, because we ignore+        -- most of the disturbances, since the player is mostly aware of them+        -- and still explicitly requests a run, knowing how it behaves.+        runStopOrCmd <- moveRunAid leader dir+        case runStopOrCmd of+          Left stopMsg -> failWith stopMsg+          Right runCmd -> do+            sel <- getsClient sselected+            let runMembers = if isSpawnFact fact+                             then [leader]  -- TODO: warn?+                             else ES.toList (ES.delete leader sel) ++ [leader]+                runParams = RunParams { runLeader = leader+                                      , runMembers+                                      , runDist = 0+                                      , runStopMsg = Nothing+                                      , runInitDir = Just dir }+            when run $ modifyClient $ \cli -> cli {srunning = Just runParams}+            return $ Right runCmd+        -- 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+      [((target, _), _)] | run ->+        -- Displacing requires accessibility, but it's checked later on.+        displaceAid leader target+      _ : _ : _ | run -> do+        assert (all (bproj . snd . fst) tgts) skip+        failSer DisplaceProjectiles+      ((target, tb), _) : _ -> do+        -- No problem if there are many projectiles at the spot. We just+        -- attack the first one.+        -- We always see actors from our own faction.+        if bfid tb == bfid sb && not (bproj tb) then do+          if isSpawnFact fact then+            failWith "spawners cannot manually change leaders"+          else do+            -- Select adjacent actor by bumping into him. Takes no time.+            success <- pickLeader target+            assert (success `blame` "bump self"+                            `twith` (leader, target, tb)) skip+            return $ Left mempty+        else+          -- Attacking does not require full access, adjacency is enough.+          meleeAid leader target+ -- | Actor atttacks an enemy actor or his own projectile.-meleeAid :: (MonadClientAbort m, MonadClientUI m)-          => ActorId -> ActorId -> m CmdSerTakeTime+meleeAid :: MonadClientUI m+         => ActorId -> ActorId -> m (SlideOrCmd CmdTakeTimeSer) 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+  let returnCmd = return $ Right $ MeleeSer source target+  if not (bproj tb || isAtWar sfact (bfid tb)) then do+    go1 <- displayYesNo ColorBW+             "This attack will start a war. Are you sure?"+    if not go1 then failWith "Attack canceled."+    else if not (bproj tb || not (isAllied sfact (bfid tb))) then do+      go2 <- displayYesNo ColorBW+               "You are bound by an alliance. Really attack?"+      if not go2 then failWith "Attack canceled."+      else returnCmd+    else returnCmd+  else returnCmd   -- 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.  -- | Actor swaps position with another.-displaceAid :: (MonadClientAbort m, MonadClientUI m)-            => ActorId -> ActorId -> m CmdSerTakeTime+displaceAid :: MonadClientUI m+            => ActorId -> ActorId -> m (SlideOrCmd CmdTakeTimeSer) 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+  let adj = checkAdjacent sb tb+  if not adj then failSer DisplaceDistant+  else do+    let lid = blid sb+    lvl <- getLevel lid+    let spos = bpos sb+        tpos = bpos tb     -- Displacing requires full access.-    return $ DisplaceSer source target-  else abortFailure DisplaceAccess---- | 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+    if accessible cops lvl spos tpos then do+      tgts <- getsState $ posToActors tpos lid+      case tgts of+        [] -> assert `failure` (source, sb, target, tb)+        [_] -> do+          return $ Right $ DisplaceSer source target+        _ -> failSer DisplaceProjectiles+    else failSer DisplaceAccess  -- * Wait  -- | Leader waits a turn (and blocks, etc.).-waitHuman :: MonadClientUI m => m CmdSerTakeTime+waitHuman :: MonadClientUI m => m CmdTakeTimeSer waitHuman = do+  modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}   leader <- getLeaderUI-  return $ WaitSer leader+  return $! WaitSer leader  -- * Pickup -pickupHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSerTakeTime+pickupHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer) pickupHuman = do   leader <- getLeaderUI   body <- getsState $ getActorBody leader   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"+    Nothing -> failWith "nothing here"     Just ((iid, k), _) ->  do  -- pick up first item; TODO: let pl select item       item <- getsState $ getItemBody iid       let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing       case assignLetter iid l body of-        Just l2 -> return $ PickupSer leader iid k l2-        Nothing -> abortWith "cannot carry any more"+        Just _ -> return $ Right $ PickupSer leader iid k+        Nothing -> failSer PickupOverfull  -- * Drop --- TODO: you can drop an item already on the floor, which works correctly,--- but is weird and useless.+-- TODO: you can drop an item already on the floor (the '-' is there),+-- which is weird and useless. -- | Drop a single item.-dropHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSerTakeTime+dropHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer) dropHuman = do   -- TODO: allow dropping a given number of identical items.   Kind.COps{coitem} <- getsState scops   leader <- getLeaderUI   bag <- getsState $ getActorBag leader   inv <- getsState $ getActorInv leader-  ((iid, item), (_, container)) <--    getAnyItem leader "What to drop?" bag inv "in inventory"-  case container of-    CFloor{} -> neverMind True-    CActor aid _ -> do-      assert (aid == leader) skip-      disco <- getsClient sdisco-      subject <- partAidLeader leader-      msgAdd $ makeSentence-        [ MU.SubjectVerbSg subject "drop"-        , partItemWs coitem disco 1 item ]-      return $ DropSer leader iid+  ggi <- getAnyItem leader "What to drop?" bag inv "in inventory"+  case ggi of+    Right ((iid, item), (_, container)) ->+      case container of+        CFloor{} -> failWith "never mind"+        CActor aid _ -> do+          assert (aid == leader) skip+          disco <- getsClient sdisco+          subject <- partAidLeader leader+          msgAdd $ makeSentence+            [ MU.SubjectVerbSg subject "drop"+            , partItemWs coitem disco 1 item ]+          return $ Right $ DropSer leader iid 1+    Left slides -> return $ Left slides  allObjectsName :: Text allObjectsName = "Objects"  -- | Let the human player choose any item from a list of items.-getAnyItem :: (MonadClientAbort m, MonadClientUI m)+getAnyItem :: MonadClientUI m            => ActorId            -> Text     -- ^ prompt            -> ItemBag  -- ^ all items in question            -> ItemInv  -- ^ inventory characters            -> Text     -- ^ how to refer to the collection of items-           -> m ((ItemId, Item), (Int, Container))+           -> m (SlideOrCmd ((ItemId, Item), (Int, Container))) getAnyItem leader prompt = getItem leader prompt (const True) allObjectsName  data ItemDialogState = INone | ISuitable | IAll deriving Eq  -- | Let the human player choose a single, preferably suitable, -- item from a list of items.-getItem :: (MonadClientAbort m, MonadClientUI m)+getItem :: MonadClientUI m         => ActorId         -> Text            -- ^ prompt message         -> (Item -> Bool)  -- ^ which items to consider suitable@@ -194,16 +262,16 @@         -> ItemBag         -- ^ all items in question         -> ItemInv         -- ^ inventory characters         -> Text            -- ^ how to refer to the collection of items-        -> m ((ItemId, Item), (Int, Container))-getItem aid prompt p ptext bag inv isn = do+        -> m (SlideOrCmd ((ItemId, Item), (Int, Container)))+getItem aid prompt p ptext bag invRaw isn = do   leader <- getLeaderUI   b <- getsState $ getActorBody leader   lvl <- getLevel $ blid b   s <- getState   body <- getsState $ getActorBody aid-  let checkItem (l, iid) =-        fmap (\k -> ((iid, getItemBody iid s), (k, l))) $ EM.lookup iid bag-      is0 = mapMaybe checkItem $ EM.assocs inv+  let inv = EM.filter (`EM.member` bag) invRaw+      checkItem (l, iid) = ((iid, getItemBody iid s), (bag EM.! iid, l))+      is0 = map checkItem $ EM.assocs inv       pos = bpos body       tis = lvl `atI` pos       floorFull = not $ EM.null tis@@ -228,9 +296,9 @@                  r = letterRange mls              in "[" <> r <> ", ?" <> floorMsg <> bestMsg       ask = do-        when (null is0 && EM.null tis) $-          abortWith "Not carrying anything."-        perform INone+        if null is0 && EM.null tis+        then failWith "Not carrying anything."+        else perform INone       invP = EM.filter (\iid -> p (getItemBody iid s)) inv       perform itemDialogState = do         let (ims, invOver, msg) = case itemDialogState of@@ -238,43 +306,59 @@               ISuitable -> (isp, invP, ptext <+> isn <> ".")               IAll      -> (is0, inv, allObjectsName <+> isn <> ".")         io <- itemOverlay bag invOver-        km@K.KM {..} <--          displayChoiceUI (msg <+> choice ims) io (keys ims)-        assert (modifier == K.NoModifier) skip-        case key of-          K.Char '?' -> case itemDialogState of-            INone -> perform ISuitable-            ISuitable | ptext /= allObjectsName -> perform IAll-            _ -> perform INone-          K.Char '-' | floorFull ->-            -- TODO: let player select item-            return $ maximumBy (compare `on` fst . fst)-                   $ map (\(iid, k) ->-                           ((iid, getItemBody iid s),-                            (k, CFloor (blid b) pos)))-                   $ EM.assocs tis-          K.Char l ->-            case find ((InvChar l ==) . snd . snd) ims of-              Nothing -> assert `failure` "unexpected inventory letter"-                                `twith` (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` "unexpected key:" `twith` km+        akm <- displayChoiceUI (msg <+> choice ims) io (keys is0)+        case akm of+          Left slides -> failSlides slides+          Right (km@K.KM {..}) -> do+            assert (modifier == K.NoModifier) skip+            case key of+              K.Char '?' -> case itemDialogState of+                INone -> if EM.null invP+                         then perform IAll+                         else perform ISuitable+                ISuitable | ptext /= allObjectsName -> perform IAll+                _ -> perform INone+              K.Char '-' | floorFull ->+                -- TODO: let player select item+                return $ Right+                       $ maximumBy (compare `on` fst . fst)+                       $ map (\(iid, k) ->+                               ((iid, getItemBody iid s),+                                (k, CFloor (blid b) pos)))+                       $ EM.assocs tis+              K.Char l ->+                case find ((InvChar l ==) . snd . snd) is0 of+                  Nothing -> assert `failure` "unexpected inventory letter"+                                    `twith` (km, l,  is0)+                  Just (iidItem, (k, l2)) ->+                    return $ Right (iidItem, (k, CActor aid l2))+              K.Return | bestFull ->+                let (iidItem, (k, l2)) = maximumBy (compare `on` snd . snd) isp+                in return $ Right (iidItem, (k, CActor aid l2))+              _ -> assert `failure` "unexpected key:" `twith` km   ask  -- * Project -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" `twith` source+projectHuman :: MonadClientUI m+             => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer)+projectHuman ts = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  tgtPos <- leaderTgtToPos+  case tgtPos of+    Nothing -> failWith "last target invalid"+    Just pos | pos == bpos b -> failWith "cannot aim at oneself"+    Just pos -> do+      canAim <- leaderTgtAims+      case canAim of+        Nothing -> projectAid leader ts pos+        Just cause -> failWith cause++projectAid :: MonadClientUI m+           => ActorId -> [Trigger] -> Point -> m (SlideOrCmd CmdTakeTimeSer)+projectAid source ts tpos = do+  Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops   eps <- getsClient seps   sb <- getsState $ getActorBody source   let lid = blid sb@@ -283,24 +367,28 @@   Level{lxsize, lysize} <- getLevel lid   foes <- getsState $ actorNotProjList (isAtWar fact) lid   if foesAdjacent lxsize lysize spos foes-    then abortFailure ProjectBlockFoes+    then failSer ProjectBlockFoes     else do       case bla lxsize lysize eps spos tpos of-        Nothing -> abortFailure ProjectAimOnself+        Nothing -> failSer ProjectAimOnself         Just [] -> assert `failure` "project from the edge of level"                           `twith` (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+          if not $ Tile.isWalkable cotile t+            then failSer ProjectBlockTerrain+            else do+              mab <- getsState $ posToActor pos lid+              if maybe True (bproj . snd . fst) mab+              then if not (asight $ okind $ bkind sb)+                   then failSer ProjectBlind+                   else projectBla source tpos eps ts+              else failSer ProjectBlockActor -projectBla :: (MonadClientAbort m, MonadClientUI m)-           => ActorId -> Point -> Int -> [Trigger] -> m CmdSerTakeTime+projectBla :: MonadClientUI m+           => ActorId -> Point -> Int -> [Trigger]+           -> m (SlideOrCmd CmdTakeTimeSer) projectBla source tpos eps ts = do   let (verb1, object1) = case ts of         [] -> ("aim", "object")@@ -308,14 +396,12 @@       triggerSyms = triggerSymbols ts   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+  ggi <- getGroupItem source bag inv object1 triggerSyms+           (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"+  case ggi of+    Right ((iid, _), (_, container)) ->+      return $ Right $ ProjectSer source tpos eps iid container+    Left slides -> return $ Left slides  triggerSymbols :: [Trigger] -> [Char] triggerSymbols [] = []@@ -324,8 +410,7 @@  -- * Apply -applyHuman :: (MonadClientAbort m, MonadClientUI m)-           => [Trigger] -> m CmdSerTakeTime+applyHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer) applyHuman ts = do   leader <- getLeaderUI   bag <- getsState $ getActorBag leader@@ -334,15 +419,17 @@         [] -> ("activate", "object")         tr : _ -> (verb tr, object tr)       triggerSyms = triggerSymbols ts-  ((iid, _), (_, container)) <--    getGroupItem leader bag inv object1 triggerSyms-                 (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"-  return $! ApplySer leader iid container+  ggi <- getGroupItem leader bag inv object1 triggerSyms+           (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"+  case ggi of+    Right ((iid, _), (_, container)) ->+      return $ Right $ ApplySer leader iid container+    Left slides -> return $ Left slides  -- | Let a human player choose any item with a given group name. -- Note that this does not guarantee the chosen item belongs to the group, -- as the player can override the choice.-getGroupItem :: (MonadClientAbort m, MonadClientUI m)+getGroupItem :: MonadClientUI m              => ActorId              -> ItemBag  -- ^ all objects in question              -> ItemInv  -- ^ inventory characters@@ -350,7 +437,7 @@              -> [Char]   -- ^ accepted item symbols              -> Text     -- ^ prompt              -> Text     -- ^ how to refer to the collection of objects-             -> m ((ItemId, Item), (Int, Container))+             -> m (SlideOrCmd ((ItemId, Item), (Int, Container))) getGroupItem leader is inv object syms prompt packName = do   let choice i = jsymbol i `elem` syms       header = makePhrase [MU.Capitalize (MU.Ws object)]@@ -359,23 +446,24 @@ -- * AlterDir  -- | Ask for a direction and alter a tile, if possible.-alterDirHuman :: (MonadClientAbort m, MonadClientUI m)-              => [Trigger] -> m CmdSerTakeTime+alterDirHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer) alterDirHuman ts = do   let verb1 = case ts of         [] -> "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-  Level{lxsize} <- getLevel $ blid b-  K.handleDir lxsize e (flip (alterTile leader) ts) (neverMind True)+  me <- displayChoiceUI prompt emptyOverlay keys+  case me of+    Left slides -> failSlides slides+    Right e -> do+      leader <- getLeaderUI+      K.handleDir e (flip (alterTile leader) ts) (failWith "never mind")  -- | Player tries to alter a tile using a feature.-alterTile :: (MonadClientAbort m, MonadClientUI m)-          => ActorId -> Vector -> [Trigger] -> m CmdSerTakeTime+alterTile :: MonadClientUI m+          => ActorId -> Vector -> [Trigger]+          -> m (SlideOrCmd CmdTakeTimeSer) alterTile source dir ts = do   Kind.COps{cotile} <- getsState scops   b <- getsState $ getActorBody source@@ -384,8 +472,8 @@       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+    [] -> failWith $ guessAlter cotile alterFeats t+    feat : _ -> return $ Right $ AlterSer source tpos $ Just feat  alterFeatures :: [Trigger] -> [F.Feature] alterFeatures [] = []@@ -393,30 +481,39 @@ 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+guessAlter :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg+guessAlter cotile (F.OpenTo _ : _) t+  | Tile.isClosable cotile t = "already open"+guessAlter _ (F.OpenTo _ : _) _ = "cannot be opened"+guessAlter cotile (F.CloseTo _ : _) t+  | Tile.isOpenable cotile t = "already closed"+guessAlter _ (F.CloseTo _ : _) _ = "cannot be closed"+guessAlter _ _ _ = "never mind"  -- * TriggerTile  -- | Leader tries to trigger the tile he's standing on.-triggerTileHuman :: (MonadClientAbort m, MonadClientUI m)-                 => [Trigger] -> m CmdSerTakeTime+triggerTileHuman :: MonadClientUI m+                 => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer) triggerTileHuman ts = do-  leader <- getLeaderUI-  triggerTile leader ts+  tgtMode <- getsClient stgtMode+  if isJust tgtMode then do+    let getK tfs = case tfs of+          TriggerFeature {feature = F.Cause (Effect.Ascend k)} : _ -> Just k+          _ : rest -> getK rest+          [] -> Nothing+        mk = getK ts+    case mk of+      Nothing -> failWith  "never mind"+      Just k -> fmap Left $ tgtAscendHuman k+  else do+    leader <- getLeaderUI+    triggerTile leader ts  -- | Player tries to trigger a tile using a feature.-triggerTile :: (MonadClientAbort m, MonadClientUI m)-            => ActorId -> [Trigger] -> m CmdSerTakeTime+triggerTile :: MonadClientUI m+            => ActorId -> [Trigger]+            -> m (SlideOrCmd CmdTakeTimeSer) triggerTile leader ts = do   Kind.COps{cotile} <- getsState scops   b <- getsState $ getActorBody leader@@ -424,10 +521,12 @@   let t = lvl `at` bpos b       triggerFeats = triggerFeatures ts   case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of-    [] -> guessTrigger cotile triggerFeats t+    [] -> failWith $ guessTrigger cotile triggerFeats t     feat : _ -> do-      verifyTrigger leader feat-      return $! TriggerSer leader $ Just feat+      go <- verifyTrigger leader feat+      case go of+        Right () -> return $ Right $ TriggerSer leader $ Just feat+        Left slides -> return $ Left slides  triggerFeatures :: [Trigger] -> [F.Feature] triggerFeatures [] = []@@ -435,74 +534,114 @@ triggerFeatures (_ : ts) = triggerFeatures ts  -- | Verify important feature triggers, such as fleeing the dungeon.-verifyTrigger :: (MonadClientAbort m, MonadClientUI m)-              => ActorId -> F.Feature -> m ()+verifyTrigger :: MonadClientUI m+              => ActorId -> F.Feature -> m (SlideOrCmd ()) verifyTrigger leader feat = case feat of-  F.Cause Effect.Escape -> do+  F.Cause Effect.Escape{} -> do+    cops <- getsState scops     b <- getsState $ getActorBody leader     side <- getsClient sside-    spawn <- getsState $ isSpawnFaction side-    summon <- getsState $ isSummonFaction side-    when (spawn || summon) $ abortWith+    fact <- getsState $ (EM.! side) . sfactionD+    let isHero = isHeroFact cops fact+    if not isHero then failWith       "This is the way out, but where would you go in this alien world?"-    go <- displayYesNo ColorFull "This is the way out. Really leave now?"-    unless go $ abortWith "Game resumed."-    (_, total) <- getsState $ calculateTotal b-    when (total == 0) $ do-      -- The player can back off at each of these steps.-      go1 <- displayMore ColorBW-               "Afraid of the challenge? Leaving so soon and empty-handed?"-      unless go1 $ abortWith "Brave soul!"-      go2 <- displayMore ColorBW-               "Next time try to grab some loot before escape!"-      unless go2 $ abortWith "Here's your chance!"-  _ -> return ()+    else do+      go <- displayYesNo ColorFull "This is the way out. Really leave now?"+      if not go then failWith "Game resumed."+      else do+        (_, total) <- getsState $ calculateTotal b+        if total == 0 then do+          -- The player can back off at each of these steps.+          go1 <- displayMore ColorBW+                   "Afraid of the challenge? Leaving so soon and empty-handed?"+          if not go1 then failWith "Brave soul!"+          else do+             go2 <- displayMore ColorBW+                     "Next time try to grab some loot before escape!"+             if not go2 then failWith "Here's your chance!"+             else return $ Right ()+        else return $ Right ()+  _ -> return $ Right ()  -- | Guess and report why the bump command failed.-guessTrigger :: MonadClientAbort m-             => Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> m a+guessTrigger :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg 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+    if k > 0 then "the way goes down, not up"+    else if k < 0 then "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+    if k > 0 then "cannot ascend"+    else if k < 0 then "cannot descend"+    else assert `failure` fs+guessTrigger _ _ _ = "never mind" +-- * StepToTarget++stepToTargetHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer)+stepToTargetHuman = do+  tgtMode <- getsClient stgtMode+  -- Movement is legal only outside targeting mode.+  -- TODO: use this command for something in targeting mode.+  if isJust tgtMode then failWith "cannot move in targeting mode"+  else do+    leader <- getLeaderUI+    b <- getsState $ getActorBody leader+    tgtPos <- leaderTgtToPos+    case tgtPos of+      Nothing -> failWith "target not set"+      Just c | c == bpos b -> failWith "target reached"+      Just c -> do+        (_, mpath) <- getCacheBfsAndPath leader c+        case mpath of+          Nothing -> failWith "no route to target"+          Just [] -> assert `failure` (leader, b, bpos b, c)+          Just (p1 : _) -> do+            as <- getsState $ posToActors p1 (blid b)+            if not $ null as then+              failWith "actor in the path to target"+            else+              moveRunHuman False $ towards (bpos b) p1++-- * Resend++resendHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer)+resendHuman = do+  slastCmd <- getsClient slastCmd+  case slastCmd of+    Just cmd -> return $ Right cmd+    Nothing -> failWith "no time-taking command to repeat"+ -- * GameRestart; does not take time -gameRestartHuman :: (MonadClientAbort m, MonadClientUI m) => Text -> m CmdSer+gameRestartHuman :: MonadClientUI m => Text -> m (SlideOrCmd CmdSer) gameRestartHuman t = do   let msg = "You just requested a new" <+> t <+> "game."   b1 <- displayMore ColorFull msg-  unless b1 $ neverMind True-  b2 <- displayYesNo ColorBW-          "Current progress will be lost! Really restart the game?"-  msg2 <- rndToAction $ oneOf-            [ "Yea, would be a pity to leave them all to die."-            , "Yea, a shame to get your own team stranded." ]-  unless b2 $ abortWith msg2-  leader <- getLeaderUI-  return $ GameRestartSer leader t+  if not b1 then failWith "never mind"+  else do+    b2 <- displayYesNo ColorBW+            "Current progress will be lost! Really restart the game?"+    msg2 <- rndToAction $ oneOf+              [ "Yea, would be a pity to leave them all to die."+              , "Yea, a shame to get your own team stranded." ]+    if not b2 then failWith msg2+    else do+      leader <- getLeaderUI+      DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+      ConfigUI{configHeroNames} <- getsClient sconfigUI+      return $ Right $ GameRestartSer leader t sdifficultyCli configHeroNames  -- * GameExit; does not take time -gameExitHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer+gameExitHuman :: MonadClientUI m => m (SlideOrCmd CmdSer) gameExitHuman = do   go <- displayYesNo ColorFull "Really save and exit?"   if go then do     leader <- getLeaderUI-    return $ GameExitSer leader-  else abortWith "Save and exit canceled."+    DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+    return $ Right $ GameExitSer leader sdifficultyCli+  else failWith "Save and exit canceled."  -- * GameSave; does not take time @@ -511,4 +650,4 @@   leader <- getLeaderUI   -- TODO: do not save to history:   msgAdd "Saving game backup."-  return $ GameSaveSer leader+  return $! GameSaveSer leader
Game/LambdaHack/Client/HumanLocal.hs view
@@ -2,29 +2,33 @@ -- server commands. None of such commands takes game time. -- TODO: document module Game.LambdaHack.Client.HumanLocal-  ( -- * Semantics of serverl-less human commands-    moveCursor, retargetLeader-  , selectHeroHuman, memberCycleHuman, memberBackHuman-  , inventoryHuman, tgtFloorLeader, tgtEnemyLeader, tgtAscendHuman-  , epsIncrHuman, cancelHuman, displayMainMenu, acceptHuman, clearHuman-  , historyHuman, humanMarkVision, humanMarkSmell, humanMarkSuspect-  , helpHuman-    -- * Helper functions useful also elsewhere-  , endTargeting, floorItemOverlay, itemOverlay, viewedLevel, selectLeader-  , stopRunning, lookAt+  ( -- * Assorted commands that do not notify the server+    gameDifficultyCycle+  , pickLeaderHuman, memberCycleHuman, memberBackHuman, inventoryHuman+  , selectActorHuman, selectNoneHuman, clearHuman, repeatHuman, recordHuman+  , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman+  , helpHuman, mainMenuHuman, macroHuman+    -- * Commands specific to targeting+  , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman+  , tgtUnknownHuman, tgtItemHuman, tgtStairHuman, tgtAscendHuman+  , epsIncrHuman, tgtClearHuman, cancelHuman, acceptHuman+    -- * Helper definitions+  , floorItemOverlay, itemOverlay+  , pickLeader, lookAt   ) where  -- Cabal import qualified Paths_LambdaHack as Self (version) +import Control.Exception.Assert.Sugar import Control.Monad-import Control.Monad.Writer.Strict (WriterT, tell) import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Function import Data.List import qualified Data.Map.Strict as M import Data.Maybe+import Data.Monoid import Data.Ord import Data.Text (Text) import qualified Data.Text as T@@ -32,17 +36,17 @@ import Game.LambdaHack.Frontend (frontendName) import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.Binding-import qualified Game.LambdaHack.Client.HumanCmd as HumanCmd import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F+import qualified Game.LambdaHack.Common.HumanCmd as HumanCmd import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Key as K import qualified Game.LambdaHack.Common.Kind as Kind@@ -57,176 +61,54 @@ import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind --- * Move and Run--moveCursor :: MonadClientUI m => Vector -> Int -> WriterT Slideshow m ()-moveCursor dir n = do-  leader <- getLeaderUI-  lpos <- getsState $ bpos . getActorBody leader-  scursor <- getsClient scursor-  let cpos = fromMaybe lpos scursor-  Level{lxsize, lysize} <- cursorLevel-  let shiftB pos = shiftBounded lxsize (1, 1, lxsize - 2, lysize - 2) pos dir-  modifyClient $ \cli -> cli {scursor = Just $ iterate shiftB cpos !! n}-  doLook--cursorLevel :: MonadClient m => m Level-cursorLevel = do-  dungeon <- getsState sdungeon-  stgtMode <- getsClient stgtMode-  cli <- getClient-  let tgtId = maybe (assert `failure` "not targetting right now"-                            `twith` cli) tgtLevelId stgtMode-  return $! dungeon EM.! tgtId--viewedLevel :: MonadClientUI m => m (LevelId, Level)-viewedLevel = do-  arena <- getArenaUI-  dungeon <- getsState sdungeon-  stgtMode <- getsClient stgtMode-  let tgtId = maybe arena tgtLevelId stgtMode-  return (tgtId, dungeon EM.! tgtId)---- TODO: probably move somewhere (Level?)--- | Produces a textual description of the terrain and items at an already--- explored position. Mute for unknown positions.--- The detailed variant is for use in the targeting mode.-lookAt :: MonadClientUI m-       => Bool       -- ^ detailed?-       -> Bool       -- ^ can be seen right now?-       -> Point      -- ^ position to describe-       -> ActorId    -- ^ the actor that looks-       -> Text       -- ^ an extra sentence to print-       -> m Text-lookAt detailed canSee pos aid msg = do-  Kind.COps{coitem, cotile=cotile@Kind.Ops{okind}} <- getsState scops-  (_, lvl) <- viewedLevel-  subject <- partAidLeader aid-  s <- getState-  let is = lvl `atI` pos-      verb = MU.Text $ if canSee then "see" else "remember"-  disco <- getsClient sdisco-  let nWs (iid, k) = partItemWs coitem disco k (getItemBody iid s)-      isd = case detailed of-              _ | EM.size is == 0 -> ""-              _ | EM.size is <= 2 ->-                makeSentence [ MU.SubjectVerbSg subject verb-                             , 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 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-  scursor <- getsClient scursor-  (lid, lvl) <- viewedLevel-  per <- getPerFid lid-  leader <- getLeaderUI-  lpos <- getsState $ bpos . getActorBody leader-  target <- getsClient $ getTarget leader-  hms <- getsState $ actorList (const True) lid-  let p = fromMaybe lpos scursor-      canSee = ES.member p (totalVisible per)-      ihabitant | canSee = find (\m -> bpos m == p) hms-                | otherwise = Nothing-      enemyMsg =-        -- Even if it's the leader, give his proper name, not 'you'.-        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)"-          | actorSeesPos per leader p = ""-          | otherwise = " (not visible)"-      mode = case target of-               Just TEnemy{} -> "[targeting foe" <> vis <> "]"-               Just TPos{}   -> "[targeting position" <> vis <> "]"-               Nothing       -> "[targeting current" <> vis <> "]"-      -- Check if there's something lying around at current position.-      is = lvl `atI` p-  -- Show general info about current position.-  lookMsg <- lookAt True canSee p leader enemyMsg-  modifyClient (\st -> st {slastKey = Nothing})-  if EM.size is <= 2 then do-    slides <- promptToSlideshow (mode <+> lookMsg)-    tell slides-  else do-    io <- floorItemOverlay is-    slides <- overlayToSlideshow (mode <+> lookMsg) io-    tell slides---- | Create a list of item names.-floorItemOverlay :: MonadClient m => ItemBag -> m Overlay-floorItemOverlay bag = do-  Kind.COps{coitem} <- getsState scops-  s <- getState-  disco <- getsClient sdisco-  let is = zip (EM.assocs bag) (allLetters ++ repeat (InvChar ' '))-      pr ((iid, k), l) =-         makePhrase [ letterLabel l-                    , partItemWs coitem disco k (getItemBody iid s) ]-         <> " "-  return $ map pr is---- | Create a list of item names.-itemOverlay :: MonadClient m => ItemBag -> ItemInv -> m Overlay-itemOverlay bag inv = do-  Kind.COps{coitem} <- getsState scops-  s <- getState-  disco <- getsClient sdisco-  let checkItem (l, iid) = fmap (\k -> (l, iid, k)) $ EM.lookup iid bag-      is = mapMaybe checkItem $ EM.assocs inv-      pr (l, iid, k) =-         makePhrase [ letterLabel l-                    , partItemWs coitem disco k (getItemBody iid s) ]-         <> " "-  return $ map pr is+failWith :: MonadClientUI m => Msg -> m Slideshow+failWith msg = do+  modifyClient $ \cli -> cli {slastKey = Nothing}+  stopPlayBack+  assert (not $ T.null msg) $ promptToSlideshow msg --- * Project+-- * GameDifficultyCycle -retargetLeader :: MonadClientUI m => WriterT Slideshow m ()-retargetLeader = do-  arena <- getArenaUI-  -- TODO: do not save to history:-  msgAdd "Last target invalid."-  modifyClient $ \cli -> cli {scursor = Nothing, seps = 0}-  tgtEnemyLeader $ TgtAuto arena+gameDifficultyCycle :: MonadClientUI m => m ()+gameDifficultyCycle = do+  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+  let d = if sdifficultyCli <= -4 then 4 else sdifficultyCli - 1+  modifyClient $ \cli -> cli {sdebugCli = (sdebugCli cli) {sdifficultyCli = d}}+  msgAdd $ "Next game difficulty set to" <+> tshow (5 - d) <> "." --- * SelectHero+-- * PickLeader -selectHeroHuman :: (MonadClientAbort m, MonadClientUI m) => Int -> m ()-selectHeroHuman k = do+pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow+pickLeaderHuman k = do   side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD   s <- getState   case tryFindHeroK s side k of-    Nothing  -> abortWith "No such member of the party."-    Just (aid, _) -> void $ selectLeader aid+    _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders"+    Nothing -> failWith "No such member of the party."+    Just (aid, _) -> do+      void $ pickLeader aid+      return mempty  -- * MemberCycle  -- | Switches current member to the next on the level, if any, wrapping.-memberCycleHuman :: (MonadClientAbort m, MonadClientUI m) => m ()+memberCycleHuman :: MonadClientUI m => m Slideshow memberCycleHuman = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD   leader <- getLeaderUI   body <- getsState $ getActorBody leader   hs <- partyAfterLeader leader   case filter (\(_, b) -> blid b == blid body) hs of-    [] -> abortWith "Cannot select any other member on this level."+    _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders"+    [] -> failWith "Cannot pick any other member on this level."     (np, b) : _ -> do-      success <- selectLeader np+      success <- pickLeader np       assert (success `blame` "same leader" `twith` (leader, np, b)) skip+      return mempty -partyAfterLeader :: MonadActionRO m-                 => ActorId-                 -> m [(ActorId, Actor)]+partyAfterLeader :: MonadActionRO m => ActorId -> m [(ActorId, Actor)] partyAfterLeader leader = do   faction <- getsState $ bfid . getActorBody leader   allA <- getsState $ EM.assocs . sactorD@@ -237,49 +119,51 @@       hs = hs9 ++ deleteFirstsBy ((==) `on` fst) factionA hs9       i = fromMaybe (-1) $ findIndex ((== leader) . fst) hs       (lt, gt) = (take i hs, drop (i + 1) hs)-  return $ gt ++ lt+  return $! gt ++ lt  -- | Select a faction leader. False, if nothing to do.-selectLeader :: MonadClientUI m => ActorId -> m Bool-selectLeader actor = do+pickLeader :: MonadClientUI m => ActorId -> m Bool+pickLeader actor = do   leader <- getLeaderUI   stgtMode <- getsClient stgtMode   if leader == actor-    then return False -- already selected+    then return False -- already picked     else do       pbody <- getsState $ getActorBody actor       assert (not (bproj pbody) `blame` "projectile chosen as the leader"                                 `twith` (actor, pbody)) skip       -- Even if it's already the leader, give his proper name, not 'you'.       let subject = partActor pbody-      msgAdd $ makeSentence [subject, "selected"]+      msgAdd $ makeSentence [subject, "picked as a leader"]       -- Update client state.       s <- getState       modifyClient $ updateLeader actor s       -- Move the cursor, if active, to the new level.-      when (isJust stgtMode) $ setTgtId $ blid pbody+      case stgtMode of+        Nothing -> return ()+        Just _ ->+          modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode $ blid pbody}       -- Inform about items, etc.-      lookMsg <- lookAt False True (bpos pbody) actor ""+      lookMsg <- lookAt False "" True (bpos pbody) actor ""       msgAdd lookMsg-      -- Don't continue an old run, if any.-      stopRunning       return True -stopRunning :: MonadClient m => m ()-stopRunning = modifyClient (\ cli -> cli { srunning = Nothing })- -- * MemberBack  -- | Switches current member to the previous in the whole dungeon, wrapping.-memberBackHuman :: (MonadClientAbort m, MonadClientUI m) => m ()+memberBackHuman :: MonadClientUI m => m Slideshow memberBackHuman = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD   leader <- getLeaderUI   hs <- partyAfterLeader leader   case reverse hs of-    [] -> abortWith "No other member in the party."+    _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders"+    [] -> failWith "No other member in the party."     (np, b) : _ -> do-      success <- selectLeader np+      success <- pickLeader np       assert (success `blame` "same leader" `twith` (leader, np, b)) skip+      return mempty  -- * Inventory @@ -287,107 +171,482 @@ -- announcing that) and show the inventory of the new leader (unless -- we have just a single inventory in the future). -- | Display inventory-inventoryHuman :: (MonadClientAbort m, MonadClientUI m)-               => WriterT Slideshow m ()+inventoryHuman :: MonadClientUI m => m Slideshow inventoryHuman = do   leader <- getLeaderUI   subject <- partAidLeader leader   bag <- getsState $ getActorBag leader-  inv <- getsState $ getActorInv leader+  invRaw <- getsState $ getActorInv leader   if EM.null bag-    then abortWith $ makeSentence+    then promptToSlideshow $ makeSentence       [ MU.SubjectVerbSg subject "be"       , "not carrying anything" ]     else do       let blurb = makePhrase             [MU.Capitalize $ MU.SubjectVerbSg subject "be carrying:"]+          inv = EM.filter (`EM.member` bag) invRaw       io <- itemOverlay bag inv-      slides <- overlayToSlideshow blurb io-      tell slides+      overlayToSlideshow blurb io --- * TgtFloor+-- * SelectActor --- | Start floor targeting mode or reset the cursor position to the leader.--- Note that the origin of a command (the hero that performs it) is unaffected--- by targeting. For example, not the targeted door, but one adjacent--- to the selected hero is closed by him.-tgtFloorLeader :: MonadClientUI m => TgtMode -> WriterT Slideshow m ()-tgtFloorLeader stgtModeNew = do+-- TODO: make the message (and for selectNoneHuman, pickLeader, etc.)+-- optional, since they have a clear representation in the UI elsewhere.+selectActorHuman ::MonadClientUI m => m Slideshow+selectActorHuman = do+  mleader <- getsClient _sleader+  case mleader of+    Nothing -> failWith "no leader picked, cannot select"+    Just leader -> do+      body <- getsState $ getActorBody leader+      wasMemeber <- getsClient $ ES.member leader . sselected+      let upd = if wasMemeber+                then ES.delete leader  -- already selected, deselect instead+                else ES.insert leader+      modifyClient $ \cli -> cli {sselected = upd $ sselected cli}+      let subject = partActor body+      msgAdd $ makeSentence [subject, if wasMemeber+                                      then "deselected"+                                      else "selected"]+      return mempty++-- * SelectNone++selectNoneHuman :: (MonadClientUI m, MonadClient m) => m ()+selectNoneHuman = do+  side <- getsClient sside+  lidV <- viewedLevel+  oursAssocs <- getsState $ actorNotProjAssocs (== side) lidV+  let ours = ES.fromList $ map fst oursAssocs+  oldSel <- getsClient sselected+  let wasNone = ES.null $ ES.intersection ours oldSel+      upd = if wasNone+            then ES.union  -- already all deselected; select all instead+            else ES.difference+  modifyClient $ \cli -> cli {sselected = upd (sselected cli) ours}+  let subject = "all party members on the level"+  msgAdd $ makeSentence [subject, if wasNone+                                  then "selected"+                                  else "deselected"]++-- * Clear++-- | Clear current messages, show the next screen if any.+clearHuman :: Monad m => m ()+clearHuman = return ()++-- * Repeat++-- Note that walk followed by repeat should not be equivalent to run,+-- because the player can really use a command that does not stop+-- at terrain change or when walking over items.+repeatHuman :: MonadClient m => Int -> m ()+repeatHuman n = do+  (_, seqPrevious, k) <- getsClient slastRecord+  let macro = concat $ replicate n $ reverse seqPrevious+  modifyClient $ \cli -> cli {slastPlay = macro ++ slastPlay cli}+  let slastRecord = ([], [], if k == 0 then 0 else maxK)+  modifyClient $ \cli -> cli {slastRecord}++maxK :: Int+maxK = 100++-- * Record++recordHuman :: MonadClientUI m => m Slideshow+recordHuman = do+  modifyClient $ \cli -> cli {slastKey = Nothing}+  (_seqCurrent, seqPrevious, k) <- getsClient slastRecord+  case k of+    0 -> do+      let slastRecord = ([], [], maxK)+      modifyClient $ \cli -> cli {slastRecord}+      promptToSlideshow $ "Macro will be recorded for up to"+                          <+> tshow maxK <+> "steps."+    _ -> do+      let slastRecord = (seqPrevious, [], 0)+      modifyClient $ \cli -> cli {slastRecord}+      promptToSlideshow $ "Macro recording interrupted after"+                          <+> tshow (maxK - k - 1) <+> "steps."++-- * History++historyHuman :: MonadClientUI m => m Slideshow+historyHuman = do+  history <- getsClient shistory+  arena <- getArenaUI+  local <- getsState $ getLocalTime arena+  global <- getsState stime+  let  msg = makeSentence+        [ "You survived for"+        , MU.CarWs (global `timeFit` timeTurn) "half-second turn"+        , "(this level:"+        , MU.Text (tshow (local `timeFit` timeTurn)) MU.:> ")" ]+        <+> "Past messages:"+  overlayToBlankSlideshow msg $ renderHistory history++-- * MarkVision, MarkSmell, MarkSuspect++markVisionHuman :: MonadClientUI m => m ()+markVisionHuman = do+  modifyClient toggleMarkVision+  cur <- getsClient smarkVision+  msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."++markSmellHuman :: MonadClientUI m => m ()+markSmellHuman = do+  modifyClient toggleMarkSmell+  cur <- getsClient smarkSmell+  msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."++markSuspectHuman :: MonadClientUI m => m ()+markSuspectHuman = do+  -- BFS takes suspect tiles into account depending on @smarkSuspect@,+  -- so we need to invalidate the BFS data caches.+  modifyClient $ \cli -> cli {sbfsD = EM.empty}+  modifyClient toggleMarkSuspect+  cur <- getsClient smarkSuspect+  msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."++-- * Help++-- | Display command help.+helpHuman :: MonadClientUI m => m Slideshow+helpHuman = do+  keyb <- askBinding+  return $! keyHelp keyb++-- * MainMenu++-- TODO: merge with the help screens better+-- | Display the main menu.+mainMenuHuman :: MonadClientUI m => m Slideshow+mainMenuHuman = do+  Kind.COps{corule} <- getsState scops+  Binding{brevMap, bcmdList} <- askBinding+  scurDifficulty <- getsClient scurDifficulty+  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+  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+                      ++ " (frontend: " ++ frontendName+                      ++ ", engine: LambdaHack " ++ showVersion Self.version+                      ++ ") "+            versionLen = length version+        in init art ++ [take (80 - versionLen) (last art) ++ version]+      kds =  -- key-description pairs+        let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd)+            revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd brevMap+            cmds = [ (K.showKM km, desc)+                   | (km, (desc, HumanCmd.CmdMenu, cmd)) <- bcmdList,+                     cmd /= HumanCmd.GameDifficultyCycle ]+        in [ (fst (revLookup HumanCmd.Cancel), "back to playing")+           , (fst (revLookup HumanCmd.Accept), "see more help") ]+           ++ cmds+           ++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle)+                     , "next game difficulty"+                       <+> tshow (5 - sdifficultyCli)+                       <+> "(current"+                       <+> tshow (5 - scurDifficulty) <> ")" ) ]+      bindingLen = 25+      bindings =  -- key bindings to display+        let fmt (k, d) = T.justifyLeft bindingLen ' '+                         $ T.justifyLeft 7 ' ' k <> " " <> d+        in map fmt kds+      overwrite =  -- overwrite the art with key bindings+        let over [] line = ([], T.pack line)+            over bs@(binding : bsRest) line =+              let (prefix, lineRest) = break (=='{') line+                  (braces, suffix)   = span  (=='{') lineRest+              in if length braces == 25+                 then (bsRest, T.pack prefix <> binding+                               <> T.drop (T.length binding - bindingLen)+                                         (T.pack suffix))+                 else (bs, T.pack line)+        in snd . mapAccumL over bindings+      mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule+      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" `twith` mainMenuArt+    hd : tl -> overlayToBlankSlideshow hd (toOverlay tl)+               -- TODO: keys don't work if tl/=[]++-- * Macro++macroHuman :: MonadClient m => [String] -> m ()+macroHuman kms =+  modifyClient $ \cli -> cli {slastPlay = map K.mkKM kms ++ slastPlay cli}++-- * MoveCursor++moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow+moveCursorHuman dir n = do   leader <- getLeaderUI-  ppos <- getsState (bpos . getActorBody leader)-  target <- getsClient $ getTarget leader   stgtMode <- getsClient stgtMode-  let tgt = case target of-        Just (TEnemy _ _) -> Nothing  -- forget enemy target, keep the cursor-        _ | isJust stgtMode ->-          Just (TPos ppos)  -- double key press: reset cursor-        t -> t  -- keep the target from previous targeting session-  -- Register that we want to target only positions.-  modifyClient $ updateTarget leader (const tgt)-  setCursor stgtModeNew+  let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode+  Level{lxsize, lysize} <- getLevel lidV+  lpos <- getsState $ bpos . getActorBody leader+  scursor <- getsClient scursor+  cursorPos <- cursorToPos+  let cpos = fromMaybe lpos cursorPos+      shiftB pos = shiftBounded lxsize lysize pos dir+      newPos = iterate shiftB cpos !! n+  if newPos == cpos then failWith "never mind"+  else do+    let tgt = case scursor of+          TVector{} -> TVector $ displacement lpos newPos+          _ -> TPoint lidV newPos+    modifyClient $ \cli -> cli {scursor = tgt}+    doLook --- | Set, activate and display cursor information.-setCursor :: MonadClientUI m => TgtMode -> WriterT Slideshow m ()-setCursor stgtModeNew = do-  stgtModeOld <- getsClient stgtMode-  scursorOld <- getsClient scursor-  sepsOld <- getsClient seps-  scursor <- targetToPos-  let seps = if scursor == scursorOld then sepsOld else 0-      stgtMode = if isNothing stgtModeOld-                   then Just stgtModeNew-                   else stgtModeOld-  modifyClient $ \cli2 -> cli2 {scursor, seps, stgtMode}+-- TODO: probably move somewhere (Level?)+-- | Produces a textual description of the terrain and items at an already+-- explored position. Mute for unknown positions.+-- The detailed variant is for use in the targeting mode.+lookAt :: MonadClientUI m+       => Bool       -- ^ detailed?+       -> Text       -- ^ how to start tile description+       -> Bool       -- ^ can be seen right now?+       -> Point      -- ^ position to describe+       -> ActorId    -- ^ the actor that looks+       -> Text       -- ^ an extra sentence to print+       -> m Text+lookAt detailed tilePrefix canSee pos aid msg = do+  Kind.COps{coitem, cotile=cotile@Kind.Ops{okind}} <- getsState scops+  lidV <- viewedLevel+  lvl <- getLevel lidV+  subject <- partAidLeader aid+  s <- getState+  let is = lvl `atI` pos+      verb = MU.Text $ if canSee then "notice" else "remember"+  disco <- getsClient sdisco+  let nWs (iid, k) = partItemWs coitem disco k (getItemBody iid s)+      isd = case detailed of+              _ | EM.size is == 0 -> ""+              _ | EM.size is <= 2 ->+                makeSentence [ MU.SubjectVerbSg subject verb+                             , MU.WWandW $ map nWs $ EM.assocs is]+              True -> "Objects:"+              _ -> "Objects here."+      tile = lvl `at` pos+      obscured | tile /= hideTile cotile lvl pos = "partially obscured"+               | otherwise = ""+      tileText = obscured <+> tname (okind tile)+      tilePart | T.null tilePrefix = MU.Text tileText+               | otherwise = MU.AW $ MU.Text tileText+      tileDesc = [MU.Text tilePrefix, tilePart]+  if not (null (Tile.causeEffects cotile tile)) then+    return $! makeSentence ("activable:" : tileDesc)+              <+> msg <+> isd+  else if detailed then+    return $! makeSentence tileDesc+              <+> 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 picked.+doLook :: MonadClientUI m => m Slideshow+doLook = do+  leader <- getLeaderUI+  stgtMode <- getsClient stgtMode+  let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode+  lvl <- getLevel lidV+  cursorPos <- cursorToPos+  per <- getPerFid lidV+  b <- getsState $ getActorBody leader+  let p = fromMaybe (bpos b) cursorPos+      canSee = ES.member p (totalVisible per)+  inhabitants <- if canSee+                 then getsState $ posToActors p lidV+                 else return []+  aims <- actorAimsPos leader p+  let enemyMsg = case inhabitants of+        [] -> ""+        _ -> -- Even if it's the leader, give his proper name, not 'you'.+             let subjects = map (partActor . snd . fst) inhabitants+                 subject = MU.WWandW subjects+                 verb = "be here"+             in makeSentence [MU.SubjectVerbSg subject verb]+      vis | not canSee = "you cannot see"+          | not aims = "you cannot penetrate"+          | otherwise = "you see"+  -- Show general info about current position.+  lookMsg <- lookAt True vis canSee p leader enemyMsg+  modifyClient $ \cli -> cli {slastKey = Nothing}+  -- Check if there's something lying around at current position.+  let is = lvl `atI` p+  if EM.size is <= 2 then+    promptToSlideshow lookMsg+  else do+    io <- floorItemOverlay is+    overlayToSlideshow lookMsg io++-- | Create a list of item names.+floorItemOverlay :: MonadClient m => ItemBag -> m Overlay+floorItemOverlay bag = do+  Kind.COps{coitem} <- getsState scops+  s <- getState+  disco <- getsClient sdisco+  let is = zip (EM.assocs bag) (allLetters ++ repeat (InvChar ' '))+      pr ((iid, k), l) =+         makePhrase [ letterLabel l+                    , partItemWs coitem disco k (getItemBody iid s) ]+         <> " "+  return $! toOverlay $ map pr is++-- | Create a list of item names.+itemOverlay :: MonadClient m => ItemBag -> ItemInv -> m Overlay+itemOverlay bag inv = do+  Kind.COps{coitem} <- getsState scops+  s <- getState+  disco <- getsClient sdisco+  let pr (l, iid) =+         makePhrase [ letterLabel l+                    , partItemWs coitem disco (bag EM.! iid)+                                 (getItemBody iid s) ]+         <> " "+  return $! toOverlay $ map pr $ EM.assocs inv++-- * TgtFloor++-- | Cycle targeting mode. Do not change position of the cursor,+-- switch among things at that position.+tgtFloorHuman :: MonadClientUI m => m Slideshow+tgtFloorHuman = do+  lidV <- viewedLevel+  leader <- getLeaderUI+  lpos <- getsState $ bpos . getActorBody leader+  cursorPos <- cursorToPos+  scursor <- getsClient scursor+  stgtMode <- getsClient stgtMode+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  bfs <- getCacheBfs leader+  bsAll <- getsState $ actorAssocs (const True) lidV+  let cursor = fromMaybe lpos cursorPos+      tgt = case scursor of+        _ | isNothing stgtMode ->  -- first key press: keep target+          scursor+        TEnemy a False -> TEnemy a True+        TEnemy{} -> TPoint lidV cursor+        TEnemyPos{} -> TPoint lidV cursor+        TPoint{} -> TVector $ displacement lpos cursor+        TVector{} ->+          let isEnemy b = isAtWar fact (bfid b)+                          && not (bproj b)+                          && posAimsPos bfs lpos (bpos b)+          -- For projectiles, we pick here the first that would be picked+          -- by '*', so that all other projectiles on the tile come next,+          -- without any intervening actors from other tiles.+          in case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of+            Just (im, m) | isEnemy m -> TEnemy im False+            Just (im, _) -> TEnemy im True+            Nothing -> TPoint lidV cursor+  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}   doLook  -- * TgtEnemy --- | Start the enemy targeting mode. Cycle between enemy targets.-tgtEnemyLeader :: MonadClientUI m => TgtMode -> WriterT Slideshow m ()-tgtEnemyLeader stgtModeNew = do+tgtEnemyHuman :: MonadClientUI m => m Slideshow+tgtEnemyHuman = do+  lidV <- viewedLevel   leader <- getLeaderUI-  ppos <- getsState (bpos . getActorBody leader)-  (lid, Level{lxsize}) <- viewedLevel-  per <- getPerFid lid-  target <- getsClient $ getTarget leader+  lpos <- getsState $ bpos . getActorBody leader+  cursorPos <- cursorToPos+  scursor <- getsClient scursor   stgtMode <- getsClient stgtMode   side <- getsClient sside   fact <- getsState $ (EM.! side) . sfactionD-  bs <- getsState $ actorNotProjAssocs (isAtWar fact) lid-  let ordPos (_, b) = (chessDist lxsize ppos $ bpos b, bpos b)-      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) dbs-              in splitAt (i + 1) dbs-            Just (TEnemy n _) ->  -- try to retarget the old enemy-              let i = fromMaybe (-1) $ findIndex ((== n) . fst) dbs-              in splitAt i dbs-            _ -> (dbs, [])  -- target first enemy (e.g., number 0)+  bfs <- getCacheBfs leader+  bsAll <- getsState $ actorAssocs (const True) lidV+  let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b)+      dbs = sortBy (comparing ordPos) bsAll+      pickUnderCursor =  -- switch to the enemy under cursor, if any+        let i = fromMaybe (-1)+                $ findIndex ((== cursorPos) . Just . bpos . snd) dbs+        in splitAt i dbs+      (permitAnyActor, (lt, gt)) = case scursor of+            TEnemy a permit | isJust stgtMode ->  -- pick next enemy+              let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs+              in (permit, splitAt (i + 1) dbs)+            TEnemy a permit ->  -- first key press, retarget old enemy+              let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs+              in (permit, splitAt i dbs)+            TEnemyPos _ _ _ permit -> (permit, pickUnderCursor)+            _ -> (False, pickUnderCursor)  -- the sensible default is only-foes       gtlt = gt ++ lt-      seen (_, b) =-        let mpos = bpos b                -- 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-              (na, nm) : _ -> Just (TEnemy na (bpos nm))  -- pick the next+      isEnemy b = isAtWar fact (bfid b)+                  && not (bproj b)+                  && posAimsPos bfs lpos (bpos b)+      lf = filter (isEnemy . snd) gtlt+      tgt | permitAnyActor = case gtlt of+        (a, _) : _ -> TEnemy a True+        [] -> scursor  -- no actors in sight, stick to last target+          | otherwise = case lf of+        (a, _) : _ -> TEnemy a False+        [] -> scursor  -- no seen foes in sight, stick to last target   -- Register the chosen enemy, to pick another on next invocation.-  modifyClient $ updateTarget leader (const tgt)-  setCursor stgtModeNew+  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}+  doLook +-- * TgtUnknown++tgtUnknownHuman :: MonadClientUI m => m Slideshow+tgtUnknownHuman = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  mpos <- closestUnknown leader+  case mpos of+    Nothing -> failWith "no more unknown spots left"+    Just p -> do+      let tgt = TPoint (blid b) p+      modifyClient $ \cli -> cli {scursor = tgt}+      return mempty++-- * TgtItem++tgtItemHuman :: MonadClientUI m => m Slideshow+tgtItemHuman = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  items <- closestItems leader+  case items of+    [] -> failWith "no more items remembered or visible"+    (_, (p, _)) : _ -> do+      let tgt = TPoint (blid b) p+      modifyClient $ \cli -> cli {scursor = tgt}+      return mempty++-- * TgtStair++tgtStairHuman :: MonadClientUI m => Bool -> m Slideshow+tgtStairHuman up = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  stairs <- closestTriggers (Just up) False leader+  case stairs of+    [] -> failWith $ "no stairs"+                     <+> if up then "up" else "down"+    p : _ -> do+      let tgt = TPoint (blid b) p+      modifyClient $ \cli -> cli {scursor = tgt}+      return mempty+ -- * TgtAscend  -- | Change the displayed level in targeting mode to (at most) -- k levels shallower. Enters targeting mode, if not already in one.-tgtAscendHuman :: (MonadClientAbort m, MonadClientUI m)-               => Int -> WriterT Slideshow m ()+tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow tgtAscendHuman k = do-  Kind.COps{cotile} <- getsState scops+  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops   dungeon <- getsState sdungeon-  cursor <- getsClient scursor-  (tgtId, lvl) <- viewedLevel-  let rightStairs = case cursor of+  scursorOld <- getsClient scursor+  cursorPos <- cursorToPos+  lidV <- viewedLevel+  lvl <- getLevel lidV+  let rightStairs = case cursorPos of         Nothing -> Nothing         Just cpos ->           let tile = lvl `at` cpos@@ -396,213 +655,104 @@              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" `twith` nln) skip+      (nln, npos) <- getsState $ whereTo lidV cpos k . sdungeon+      assert (nln /= lidV `blame` "stairs looped" `twith` 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+      let ascDesc (F.Cause (Effect.Ascend _)) = True+          ascDesc _ = False+          scursor =+            if any ascDesc $ tfeature $ okind (lvl `at` npos)+            then TPoint nln npos  -- already known as an exit, focus on it+            else scursorOld  -- unknown, do not reveal+      modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)}+      doLook     Nothing ->  -- no stairs in the right direction-      case ascendInBranch dungeon tgtId k of-        [] -> abortWith "no more levels in this direction"-        nln : _ -> setTgtId nln-  doLook--setTgtId :: MonadClient m => LevelId -> m ()-setTgtId nln = do-  stgtMode <- getsClient stgtMode-  case stgtMode of-    Just (TgtAuto _) ->-      modifyClient $ \cli -> cli {stgtMode = Just (TgtAuto nln)}-    _ ->-      modifyClient $ \cli -> cli {stgtMode = Just (TgtExplicit nln)}+      case ascendInBranch dungeon k lidV of+        [] -> failWith "no more levels in this direction"+        nln : _ -> do+          modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)}+          doLook  -- * EpsIncr  -- | Tweak the @eps@ parameter of the targeting digital line.-epsIncrHuman :: MonadClientAbort m => Bool -> m ()+epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow epsIncrHuman b = do   stgtMode <- getsClient stgtMode   if isJust stgtMode-    then modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1}-    else neverMind True  -- no visual feedback, so no sense+    then do+      modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1}+      return mempty+    else failWith "never mind"  -- no visual feedback, so no sense +-- * TgtClear++tgtClearHuman :: MonadClient m => m ()+tgtClearHuman = do+  mleader <- getsClient _sleader+  case mleader of+    Nothing -> return ()+    Just leader -> do+      tgt <- getsClient $ getTarget leader+      case tgt of+        Just _ -> modifyClient $ updateTarget leader (const Nothing)+        Nothing -> do+          scursorOld <- getsClient scursor+          b <- getsState $ getActorBody leader+          let scursor = case scursorOld of+                TEnemy _ permit -> TEnemy leader permit+                TEnemyPos _ _ _ permit -> TEnemy leader permit+                TPoint{} -> TPoint (blid b) (bpos b)+                TVector{} -> TVector (Vector 0 0)+          modifyClient $ \cli -> cli {scursor}+ -- * Cancel  -- | Cancel something, e.g., targeting mode, resetting the cursor -- to the position of the leader. Chosen target is not invalidated.-cancelHuman :: MonadClientUI m-            => WriterT Slideshow m () -> WriterT Slideshow m ()+cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow cancelHuman h = do   stgtMode <- getsClient stgtMode   if isJust stgtMode-    then endTargeting False+    then targetReject     else h  -- nothing to cancel right now, treat this as a command invocation --- TODO: merge with the help screens better--- | Display the main menu.-displayMainMenu :: MonadClientUI m => WriterT Slideshow m ()-displayMainMenu = do-  Kind.COps{corule} <- getsState scops-  Binding{krevMap} <- askBinding-  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-                      ++ " (frontend: " ++ frontendName-                      ++ ", engine: LambdaHack " ++ showVersion Self.version-                      ++ ") "-            versionLen = length version-        in init art ++ [take (80 - versionLen) (last art) ++ version]-      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.GameExit-                   , HumanCmd.GameRestart "campaign"-                   , HumanCmd.GameRestart "skirmish"-                   , HumanCmd.GameRestart "PvP"-                   , HumanCmd.GameRestart "Coop"-                   , HumanCmd.GameRestart "defense"-                   ]-        in [ (fst (revLookup HumanCmd.Cancel), "back to playing")-           , (fst (revLookup HumanCmd.Accept), "see more help") ]-           ++ map revLookup cmds-      bindings =  -- key bindings to display-        let bindingLen = 25-            fmt (k, d) =-              let gapLen = (8 - T.length k) `max` 1-                  padLen = bindingLen - T.length k - gapLen - T.length d-              in k <> T.replicate gapLen " " <> d <> T.replicate padLen " "-        in map fmt kds-      overwrite =  -- overwrite the art with key bindings-        let over [] line = ([], T.pack line)-            over bs@(binding : bsRest) line =-              let (prefix, lineRest) = break (=='{') line-                  (braces, suffix)   = span  (=='{') lineRest-              in if length braces == 25-                 then (bsRest, T.pack prefix <> binding <> T.pack suffix)-                 else (bs, T.pack line)-        in snd . mapAccumL over bindings-      mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule-      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" `twith` mainMenuArt-    hd : tl -> do-      slides <- overlayToSlideshow hd tl  -- TODO: keys don't work if tl/=[]-      tell slides+-- | End targeting mode, rejecting the current position.+targetReject :: MonadClientUI m => m Slideshow+targetReject = do+  modifyClient $ \cli -> cli {stgtMode = Nothing}+  failWith "targeting canceled"  -- * Accept  -- | Accept something, e.g., targeting mode, keeping cursor where it was. -- Or perform the default action, if nothing needs accepting.-acceptHuman :: MonadClientUI m-            => WriterT Slideshow m () -> WriterT Slideshow m ()+acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow acceptHuman h = do   stgtMode <- getsClient stgtMode   if isJust stgtMode-    then endTargeting True+    then do+      targetAccept+      return mempty     else h  -- nothing to accept right now, treat this as a command invocation --- | End targeting mode, accepting the current position or not.-endTargeting :: MonadClientUI m => Bool -> m ()-endTargeting accept = do-  when accept $ do-    leader <- getLeaderUI-    target <- getsClient $ getTarget leader-    scursor <- getsClient scursor-    (lid, _) <- viewedLevel-    side <- getsClient sside-    fact <- getsState $ (EM.! side) . sfactionD-    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) bs of-          Just (im, m)  ->-            let tgt = Just $ TEnemy im (bpos m)-            in modifyClient $ updateTarget leader (const tgt)-          Nothing -> return ()-      _ -> case scursor of-        Nothing -> return ()-        Just cpos ->-          modifyClient $ updateTarget leader (const $ Just $ TPos cpos)-  if accept-    then endTargetingMsg-    -- TODO: do not save to history:-    else msgAdd "targeting canceled"-  modifyClient $ \cli -> cli { stgtMode = Nothing }+-- | End targeting mode, accepting the current position.+targetAccept :: MonadClientUI m => m ()+targetAccept = do+  endTargeting+  endTargetingMsg+  modifyClient $ \cli -> cli {stgtMode = Nothing} +-- | End targeting mode, accepting the current position.+endTargeting :: MonadClientUI m => m ()+endTargeting = do+  leader <- getLeaderUI+  scursor <- getsClient scursor+  modifyClient $ updateTarget leader $ const $ Just scursor+ endTargetingMsg :: MonadClientUI m => m () endTargetingMsg = do   leader <- getLeaderUI-  pbody <- getsState $ getActorBody leader-  target <- getsClient $ getTarget leader-  s <- getState-  Level{lxsize} <- cursorLevel-  let targetMsg = case target of-                    Just (TEnemy a _ll) ->-                      if memActor a (blid pbody) s-                      -- Never equal to leader, hence @partActor@.-                      then partActor $ getActorBody a s-                      else "a fear of the past"-                    Just (TPos tpos) ->-                      MU.Text $ "position" <+> showPoint lxsize tpos-                    Nothing -> "current cursor position continuously"+  targetMsg <- targetDescLeader leader   subject <- partAidLeader leader-  msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", targetMsg]---- * Clear---- | Clear current messages, show the next screen if any.-clearHuman :: Monad m => m ()-clearHuman = return ()---- * History--historyHuman :: MonadClientUI m => WriterT Slideshow m ()-historyHuman = do-  history <- getsClient shistory-  arena <- getArenaUI-  local <- getsState $ getLocalTime arena-  global <- getsState stime-  let  msg = makeSentence-        [ "You survived for"-        , MU.CarWs (global `timeFit` timeTurn) "half-second turn"-        , "(this level:"-        , MU.Text (showT (local `timeFit` timeTurn)) MU.:> ")" ]-        <+> "Past messages:"-  slides <- overlayToSlideshow msg $ renderHistory history-  tell slides---- * MarkVision, MarkSmell, MarkSuspect--humanMarkVision :: MonadClientUI m => m ()-humanMarkVision = do-  modifyClient toggleMarkVision-  cur <- getsClient smarkVision-  msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."--humanMarkSmell :: MonadClientUI m => m ()-humanMarkSmell = do-  modifyClient toggleMarkSmell-  cur <- getsClient smarkSmell-  msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."--humanMarkSuspect :: MonadClientUI m => m ()-humanMarkSuspect = do-  modifyClient toggleMarkSuspect-  cur <- getsClient smarkSuspect-  msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."---- * Help---- | Display command help.-helpHuman :: MonadClientUI m => WriterT Slideshow m ()-helpHuman = do-  keyb <- askBinding-  tell $ keyHelp keyb+  msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]
Game/LambdaHack/Client/HumanSem.hs view
@@ -3,137 +3,79 @@   ( cmdHumanSem   ) where -import Control.Monad-import Control.Monad.Writer.Strict (WriterT)-import Data.Maybe+import Data.Monoid -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.HumanCmd import Game.LambdaHack.Client.HumanGlobal import Game.LambdaHack.Client.HumanLocal-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.HumanCmd import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Common.VectorXY  -- | The semantics of human player commands in terms of the @Action@ monad. -- Decides if the action takes time and what action to perform.--- Time cosuming commands are marked as such in help and cannot be+-- Some time cosuming commands are enabled in targeting mode, but cannot be -- invoked in targeting mode on a remote level (level different than--- the level of the selected hero).-cmdHumanSem :: (MonadClientAbort m, MonadClientUI m)-            => HumanCmd -> WriterT Slideshow m (Maybe CmdSer)+-- the level of the leader).+cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd CmdSer) cmdHumanSem cmd = do-  arena <- getArenaUI-  when (noRemoteHumanCmd cmd) $ checkCursor arena-  cmdAction cmd+  if noRemoteHumanCmd cmd then do+    -- If in targeting mode, check if the current level is the same+    -- as player level and refuse performing the action otherwise.+    arena <- getArenaUI+    lidV <- viewedLevel+    if (arena /= lidV) then+      failWith $ "command disabled on a remote level, press ESC to switch back"+    else cmdAction cmd+  else cmdAction cmd --- | The basic action for a command and whether it takes time.-cmdAction :: (MonadClientAbort m, MonadClientUI m)-          => HumanCmd -> WriterT Slideshow m (Maybe CmdSer)+-- | Compute the basic action for a command and mark whether it takes time.+cmdAction :: MonadClientUI m => HumanCmd -> m (SlideOrCmd CmdSer) cmdAction cmd = case cmd of-  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 . 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-  GameSave -> fmap Just gameSaveHuman--  SelectHero k -> selectHeroHuman k >> return Nothing-  MemberCycle -> memberCycleHuman >> return Nothing-  MemberBack -> memberBackHuman >> return Nothing-  Inventory -> inventoryHuman >> return Nothing-  TgtFloor -> tgtFloorHuman-  TgtEnemy -> tgtEnemyHuman-  TgtAscend k -> tgtAscendHuman k >> return Nothing-  EpsIncr b -> epsIncrHuman b >> return Nothing-  Cancel -> cancelHuman displayMainMenu >> return Nothing-  Accept -> acceptHuman helpHuman >> return Nothing-  Clear -> clearHuman >> return Nothing-  History -> historyHuman >> return Nothing-  MarkVision -> humanMarkVision >> return Nothing-  MarkSmell -> humanMarkSmell >> return Nothing-  MarkSuspect -> humanMarkSuspect >> return Nothing-  Help -> displayMainMenu >> return Nothing---- | If in targeting mode, check if the current level is the same--- as player level and refuse performing the action otherwise.-checkCursor :: (MonadClientAbort m, MonadClientUI m) => LevelId -> m ()-checkCursor arena = do-  (lid, _) <- viewedLevel-  when (arena /= lid) $-    abortWith "[targeting] command disabled on a remote level, press ESC to switch back"+  Move v -> fmap (fmap CmdTakeTimeSer) $ moveRunHuman False v+  Run v -> fmap (fmap CmdTakeTimeSer) $ moveRunHuman True v+  Wait -> fmap Right $ fmap CmdTakeTimeSer waitHuman+  Pickup -> fmap (fmap CmdTakeTimeSer) pickupHuman+  Drop -> fmap (fmap CmdTakeTimeSer) dropHuman+  Project ts -> fmap (fmap CmdTakeTimeSer) $ projectHuman ts+  Apply ts -> fmap (fmap CmdTakeTimeSer) $ applyHuman ts+  AlterDir ts -> fmap (fmap CmdTakeTimeSer) $ alterDirHuman ts+  TriggerTile ts -> fmap (fmap CmdTakeTimeSer) $ triggerTileHuman ts+  StepToTarget -> fmap (fmap CmdTakeTimeSer) stepToTargetHuman+  Resend -> fmap (fmap CmdTakeTimeSer) resendHuman -moveRunHuman :: (MonadClientAbort m, MonadClientUI m)-             => Bool -> VectorXY -> WriterT Slideshow m (Maybe CmdSer)-moveRunHuman run v = do-  tgtMode <- getsClient stgtMode-  (arena, Level{lxsize}) <- viewedLevel-  source <- getLeaderUI-  sb <- getsState $ getActorBody source-  let dir = toDir lxsize v-  if isJust tgtMode then do-    moveCursor dir (if run then 10 else 1) >> return Nothing-  else do-    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-        -- 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` "bump self" `twith` (source, target, tb)) skip-          return Nothing-        else-          -- Attacking does not require full access, adjacency is enough.-          fmap (Just . TakeTimeSer) $ meleeAid source target+  GameRestart t -> gameRestartHuman t+  GameExit -> gameExitHuman+  GameSave -> fmap Right gameSaveHuman -projectHuman :: (MonadClientAbort m, MonadClientUI m)-             => [Trigger] -> WriterT Slideshow m (Maybe CmdSer)-projectHuman ts = do-  tgtLoc <- targetToPos-  if isNothing tgtLoc-    then retargetLeader >> return Nothing-    else do-      leader <- getLeaderUI-      fmap (Just . TakeTimeSer) $ projectAid leader ts+  GameDifficultyCycle -> addNoSlides gameDifficultyCycle+  PickLeader k -> fmap Left $ pickLeaderHuman k+  MemberCycle -> fmap Left memberCycleHuman+  MemberBack -> fmap Left memberBackHuman+  Inventory -> fmap Left inventoryHuman+  SelectActor -> fmap Left selectActorHuman+  SelectNone -> addNoSlides selectNoneHuman+  Clear -> addNoSlides clearHuman+  Repeat n -> addNoSlides $ repeatHuman n+  Record -> fmap Left recordHuman+  History -> fmap Left historyHuman+  MarkVision -> addNoSlides markVisionHuman+  MarkSmell -> addNoSlides markSmellHuman+  MarkSuspect -> addNoSlides markSuspectHuman+  Help -> fmap Left helpHuman+  MainMenu -> fmap Left mainMenuHuman+  Macro _ kms -> addNoSlides $ macroHuman kms -tgtFloorHuman :: MonadClientUI m => WriterT Slideshow m (Maybe CmdSer)-tgtFloorHuman = do-  arena <- getArenaUI-  tgtFloorLeader (TgtExplicit arena) >> return Nothing+  MoveCursor v k -> fmap Left $ moveCursorHuman v k+  TgtFloor -> fmap Left tgtFloorHuman+  TgtEnemy -> fmap Left tgtEnemyHuman+  TgtUnknown -> fmap Left tgtUnknownHuman+  TgtItem -> fmap Left tgtItemHuman+  TgtStair up -> fmap Left $ tgtStairHuman up+  TgtAscend k -> fmap Left $ tgtAscendHuman k+  EpsIncr b -> fmap Left $ epsIncrHuman b+  TgtClear -> addNoSlides tgtClearHuman+  Cancel -> fmap Left $ cancelHuman mainMenuHuman+  Accept -> fmap Left $ acceptHuman helpHuman -tgtEnemyHuman :: MonadClientUI m => WriterT Slideshow m (Maybe CmdSer)-tgtEnemyHuman = do-  arena <- getArenaUI-  tgtEnemyLeader (TgtExplicit arena) >> return Nothing+addNoSlides :: Monad m => m () -> m (SlideOrCmd CmdSer)+addNoSlides cmdCli = cmdCli >> return (Left mempty)
Game/LambdaHack/Client/LoopAction.hs view
@@ -3,6 +3,7 @@ -- moves turn by turn. module Game.LambdaHack.Client.LoopAction (loopAI, loopUI) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.Text as T @@ -16,20 +17,20 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.State import Game.LambdaHack.Content.RuleKind-import Control.Exception.Assert.Sugar  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+  sconfigUI <- getsClient sconfigUI  -- config from file, not savegame   modifyClient $ \cli -> cli {sdebugCli}   restored <- restoreGame   case restored of     Just (s, cli) | not $ snewGameCli sdebugCli -> do  -- Restore the game.       let sCops = updateCOps (const cops) s       putSt sCops-      putClient cli {sdebugCli}+      putClient cli {sdebugCli, sconfigUI}       return True     _ ->  -- First visit ever, use the initial state.       return False@@ -43,19 +44,19 @@   cmd1 <- readServer   case (restored, cmd1) of     (True, CmdAtomicAI ResumeA{}) -> return ()-    (True, CmdAtomicAI RestartA{}) -> return ()  -- ignoring old savefile+    (True, CmdAtomicAI RestartA{}) -> return ()     (False, CmdAtomicAI ResumeA{}) -> do       removeServerSave       error $ T.unpack $-        "Savefile of client" <+> showT side+        "Savefile of client" <+> tshow side         <+> "not usable. Removing server savefile. Please restart now."     (False, CmdAtomicAI RestartA{}) -> return ()     _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)   cmdClientAISem cmd1   -- State and client state now valid.-  debugPrint $ "AI client" <+> showT side <+> "started."+  debugPrint $ "AI client" <+> tshow side <+> "started."   loop-  debugPrint $ "AI client" <+> showT side <+> "stopped."+  debugPrint $ "AI client" <+> tshow side <+> "stopped."  where   loop = do     cmd <- readServer@@ -84,7 +85,7 @@     (False, CmdAtomicUI ResumeA{}) -> do       removeServerSave       error $ T.unpack $-        "Savefile of client" <+> showT side+        "Savefile of client" <+> tshow side         <+> "not usable. Removing server savefile. Please restart now."     (False, CmdAtomicUI RestartA{}) -> do       let msg = "Welcome to" <+> title <> "!"@@ -92,9 +93,9 @@       msgAdd msg     _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)   -- State and client state now valid.-  debugPrint $ "UI client" <+> showT side <+> "started."+  debugPrint $ "UI client" <+> tshow side <+> "started."   loop-  debugPrint $ "UI client" <+> showT side <+> "stopped."+  debugPrint $ "UI client" <+> tshow side <+> "stopped."  where   loop = do     cmd <- readServer
Game/LambdaHack/Client/RunAction.hs view
@@ -1,211 +1,276 @@+{-# LANGUAGE RankNTypes #-} -- | Running and disturbance.+--+-- The general rule is: whatever is behind you (and so ignored previously),+-- determines what you ignore moving forward. This is calcaulated+-- separately for the tiles to the left, to the right and in the middle+-- along the running direction. So, if you want to ignore something+-- start running when you stand on it (or to the right or left, respectively)+-- or by entering it (or passing to the right or left, respectively).+--+-- Some things are never ignored, such as: enemies seen, imporant messages+-- heard, solid tiles and actors in the way. module Game.LambdaHack.Client.RunAction-  ( continueRunDir+  ( continueRun, moveRunAid   ) where +import Control.Exception.Assert.Sugar+import Control.Monad import qualified Data.ByteString.Char8 as BS import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import qualified Data.List as L+import Data.Function+import Data.List import Data.Maybe -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.State 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.Perception import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY+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.Content.TileKind --- | Start running in the given direction and with the given number--- of tiles already traversed (usually 0). The first turn of running--- succeeds much more often than subsequent turns, because most--- of the disturbances are ignored, since the player is aware of them--- and still explicitly requests a run.-canRun :: MonadClient m => ActorId -> (Vector, Int) -> m Bool-canRun leader (dir, dist) = do-  cops <- getsState scops-  b <- getsState $ getActorBody leader-  lvl <- getLevel $ blid b-  stgtMode <- getsClient stgtMode-  assert (isNothing stgtMode `blame` "attempt to run in target mode"-                             `twith` (dir, dist, stgtMode)) skip-  return $ accessibleDir cops lvl (bpos b) dir--runDir :: MonadClient m => ActorId -> (Vector, Int) -> m (Vector, Int)-runDir leader (dir, dist) = do-  canR <- canRun leader (dir, dist)-  let -- Do not count distance if we just open a door.-      distNew = if canR then dist + 1 else dist-  return (dir, distNew)---- | 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---- | Determine the running mode. For corridors, pick the running direction--- trying to explore all corners, by prefering cardinal to diagonal moves.-runMode :: Point -> Vector -> (Point -> Vector -> Bool) -> X -> RunMode-runMode pos dir dirEnterable lxsize =-  let dirNearby dir1 dir2 = euclidDistSq lxsize dir1 dir2 == 1-      dirBackward d = euclidDistSq lxsize (neg dir) d <= 1-      dirAhead d = euclidDistSq lxsize dir d <= 2-      findOpen =-        let f dirC open = open ++-              case L.filter (dirNearby dirC) dirsEnterable of-                l | dirBackward dirC -> dirC : l  -- points backwards-                []  -> []  -- a narrow corridor, just one tile wide-                [_] -> []  -- a turning corridor, two tiles wide-                l   -> dirC : l  -- too wide-        in L.foldr f []-      dirsEnterable = L.filter (dirEnterable pos) (moves lxsize)-  in case dirsEnterable of-    [] -> assert `failure` "actor is stuck" `twith` (pos, dir)  -- TODO-    [negdir] -> assert (negdir == neg dir) RunDeadEnd-    _ ->-      let dirsOpen = findOpen dirsEnterable-          dirsCorridor = dirsEnterable L.\\ dirsOpen-      in case dirsCorridor of-        [] -> RunOpen  -- no corridors-        _ | L.any dirAhead dirsOpen -> RunOpen  -- open space ahead-        [d] -> RunCorridor (d, False)  -- corridor with no turn-        [d1, d2] | dirNearby d1 d2 ->  -- corridor with a turn-          -- Prefer cardinal to diagonal dirs, for hero safety,-          -- even if that means changing direction.-          RunCorridor (if diagonal lxsize d1 then d2 else d1, True)-        _ -> RunHub  -- a hub of many separate corridors+-- | Continue running in the given direction.+continueRun :: MonadClient m+            => RunParams -> m (Either Msg (RunParams, CmdTakeTimeSer))+continueRun paramOld =+  case paramOld of+    RunParams{ runMembers = []+             , runStopMsg = Just stopMsg } -> return $ Left stopMsg+    RunParams{ runLeader+             , runMembers = r : rs+             , runDist = 0+             , runStopMsg+             , runInitDir = Just dir } ->+      if r == runLeader then do+        -- Start a many-actor run with distance 1, to prevent changing+        -- direction on first turn, if the original direction is blocked.+        -- We want our runners to keep formation.+        let runDistNew = if null rs then 0 else 1+        continueRun paramOld{runDist = runDistNew, runInitDir = Nothing}+      else do+        runOutcome <- continueRunDir r 0 (Just dir)+        case runOutcome of+          Left "" -> do  -- hack; means that zeroth step OK+            runStopOrCmd <- moveRunAid r dir+            let runMembersNew = if isJust runStopMsg then rs else rs ++ [r]+                paramNew = paramOld {runMembers = runMembersNew}+            return $! case runStopOrCmd of+              Left stopMsg -> assert `failure` (paramOld, stopMsg)+              Right runCmd -> Right (paramNew, runCmd)+          Left runStopMsgCurrent -> do+            let runStopMsgNew = fromMaybe runStopMsgCurrent runStopMsg+                paramNew = paramOld { runMembers = rs+                                    , runStopMsg = Just runStopMsgNew }+            continueRun paramNew+          _ -> assert `failure` (paramOld, runOutcome)+    RunParams{ runLeader+             , runMembers = r : rs+             , runDist+             , runStopMsg+             , runInitDir = Nothing } -> do+      let runDistNew = if r == runLeader then runDist + 1 else runDist+      mdirOrRunStopMsgCurrent <- continueRunDir r runDistNew Nothing+      let runStopMsgCurrent =+            either Just (const Nothing) mdirOrRunStopMsgCurrent+          runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent+          -- We check @runStopMsgNew@, because even if the current actor+          -- runs OK, we want to stop soon if some others had to stop.+          runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]+          paramNew = paramOld { runMembers = runMembersNew+                              , runDist = runDistNew+                              , runStopMsg = runStopMsgNew }+      case mdirOrRunStopMsgCurrent of+        Left _ -> continueRun paramNew  -- run all undisturbed; only one time+        Right dir -> return $ Right (paramNew, MoveSer r dir)+      -- The potential invisible actor is hit. War is started without asking.+    _ -> assert `failure` paramOld --- TODO: express as MonadActionRO--- | 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)-               -> Kind.Ops TileKind -> Level -> X -> Y-               -> (Vector, Int) -> Maybe (Vector, Int)-runDisturbance posLast distLast report hs ms per markSuspect posHere-               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)-      enemySeen =-        not (ES.null (msposs `ES.intersection` totalVisible per))-      surrLast  = posLast : vicinity lxsize lysize posLast-      surrHere  = posHere : vicinity lxsize lysize posHere-      posThere  = posHere `shift` dirNew-      heroThere = posThere `elem` L.map bpos hs-      -- Stop if you touch any individual tile with these propereties-      -- first time, unless you enter it next move, in which case stop then.-      touchList = [ posHasFeature F.Exit-                  , posHasItems-                  ]-      -- Here additionally ignore a tile property if you stand on such tile.-      standList = [ posHasFeature F.Path-                  ]-      -- Here stop only if you touch any such tile for the first time.-      -- TODO: stop when running along a path and it ends (or turns).-      -- TODO: perhaps in open areas change direction to follow lit and paths.-      firstList = [ posHasFeature F.Lit-                  , not . posHasFeature F.Lit-                  , not . posHasFeature F.Path-                  , \t -> markSuspect && posHasFeature F.Suspect t-                    -- TODO: refine for suspect floors (e.g., traps)-                  ]-      -- TODO: stop when walls vanish from cardinal directions or when any-      -- walls re-appear again. Actually stop one tile before that happens.-      -- Then remove some other, subsumed conditions.-      -- This will help with corridors starting in dark rooms.-      touchNew fun =-        let touchLast = L.filter fun surrLast-            touchHere = L.filter fun surrHere-        in touchHere L.\\ touchLast-      touchExplore fun = touchNew fun == [posThere]-      touchStop fun = touchNew fun /= []-      standNew fun = L.filter (\pos -> posHasFeature F.Walkable pos ||-                                       Tile.openable cotile (lvl `at` pos))-                       (touchNew fun)-      standExplore fun = not (fun posHere) && standNew fun == [posThere]-      standStop fun = not (fun posHere) && standNew fun /= []-      firstNew fun = L.all (not . fun) surrLast &&-                     L.any fun surrHere-      firstExplore fun = firstNew fun && fun posThere-      firstStop = firstNew-      tryRunMaybe-        | msgShown || enemySeen-          || heroThere || distLast >= 40  = Nothing-        | L.any touchExplore touchList    = Just (dirNew, 1000)-        | L.any standExplore standList    = Just (dirNew, 1000)-        | L.any firstExplore firstList    = Just (dirNew, 1000)-        | L.any touchStop touchList       = Nothing-        | L.any standStop standList       = Nothing-        | L.any firstStop firstList       = Nothing-        | otherwise                       = Just (dirNew, distNew)-  in tryRunMaybe+-- | Actor moves or searches or alters. No visible actor at the position.+moveRunAid :: MonadClient m+           => ActorId -> Vector -> m (Either Msg CmdTakeTimeSer)+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+      runStopOrCmd =+        -- Movement requires full access.+        if accessible cops lvl spos tpos then+          -- The potential invisible actor is hit. War started without asking.+          Right $ MoveSer source dir+        -- No access, so search and/or alter the tile. Non-walkability is+        -- not implied by the lack of access.+        else if not (Tile.isWalkable cotile t)+                && (isSecretPos lvl tpos  -- possible secrets here+                    && (Tile.isSuspect cotile t  -- not yet searched+                        || hideTile cotile lvl tpos /= t)  -- searching again+                    || Tile.isOpenable cotile t+                    || Tile.isClosable cotile t+                    || Tile.isChangeable cotile t) then+          if not $ EM.null $ lvl `atI` tpos then+            Left $ showFailureSer AlterBlockItem+          else+            Right $ AlterSer source tpos Nothing+            -- We don't use MoveSer, because we don't hit invisible actors.+            -- 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.+       -- Ignore a known boring, not accessible tile.+       else Left "never mind"+  return $! runStopOrCmd  -- | This function implements the actual logic of running. It checks if we -- have to stop running because something interesting cropped up, -- it ajusts the direction given by the vector if we reached -- a corridor's corner (we never change direction except in corridors) -- and it increments the counter of traversed tiles.-continueRunDir :: MonadClientAbort m-               => ActorId -> (Vector, Int)-               -> m (Vector, Int)-continueRunDir leader (dirLast, distLast) = do+continueRunDir :: MonadClient m+               => ActorId -> Int -> Maybe Vector -> m (Either Msg Vector)+continueRunDir aid distLast mdir = do+  sreport <- getsClient sreport -- TODO: check the message before it goes into history+  let boringMsgs = map BS.pack [ "You hear some noises."+                               , "reveals that the" ]+      boring repLine = any (`BS.isInfixOf` repLine) boringMsgs+      -- TODO: use a regexp from the UI config instead+      msgShown  = isJust $ findInReport (not . boring) sreport+  if msgShown then return $ Left "message shown"+  else do+    let maxDistance = 20+    cops@Kind.COps{cotile} <- getsState scops+    body <- getsState $ getActorBody aid+    let lid = blid body+    lvl <- getLevel lid+    let posHere = bpos body+        posLast = boldpos body+        dirLast = displacement posLast posHere+        dir = fromMaybe dirLast mdir+        posThere = posHere `shift` dir+    actorsThere <- getsState $ posToActors posThere lid+    let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))+        check+          | not $ null actorsThere = return $ Left "actor in the way"+                         -- don't displace actors, except with leader in step 1+          | distLast >= maxDistance =+              return $ Left $ "reached max run distance" <+> tshow maxDistance+          | accessibleDir cops lvl posHere dir =+              if distLast == 0+              then return $ Left ""  -- hack; means that zeroth step OK+              else checkAndRun aid dir+          | distLast /= 1 = return $ Left "blocked"+                            -- don't change direction, except in step 1+          | openableLast = return $ Left "blocked by a closed door"+                           -- the player may prefer to open the door+          | otherwise =+              -- Assume turning is permitted, because this is the start+              -- of the run, so the situation is mostly known to the player+              tryTurning aid+    check++tryTurning :: MonadClient m+           => ActorId -> m (Either Msg Vector)+tryTurning aid = do   cops@Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody leader+  body <- getsState $ getActorBody aid   let lid = blid body-  per <- getPerFid lid-  sreport <- getsClient sreport -- TODO: check the message before it goes into history+  lvl <- getLevel lid+  let posHere = bpos body+      posLast = boldpos body+      dirLast = displacement posLast posHere+  let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))+      dirEnterable dir = accessibleDir cops lvl posHere dir || openableDir dir+      dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2]+      dirSimilar dir = dirNearby dirLast dir && dirEnterable dir+      dirsSimilar = filter dirSimilar moves+  case dirsSimilar of+    [] -> return $ Left "dead end"+    d1 : ds | all (dirNearby d1) ds ->  -- only one or two directions possible+      case sortBy (compare `on` euclidDistSqVector dirLast)+           $ filter (accessibleDir cops lvl posHere) $ d1 : ds of+        [] ->+          return $ Left "blocked and all similar directions are closed doors"+        d : _ -> checkAndRun aid d+    _ -> return $ Left "blocked and many distant similar directions found"++-- The direction is different than the original, if called from @tryTurning@+-- and the same if from @continueRunDir@.+checkAndRun :: MonadClient m+            => ActorId -> Vector -> m (Either Msg Vector)+checkAndRun aid dir = do+  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops+  body <- getsState $ getActorBody aid   smarkSuspect <- getsClient smarkSuspect-  fact <- getsState $ (EM.! bfid body) . sfactionD-  ms <- getsState $ actorList (isAtWar fact) lid-  hs <- getsState $ actorList (not . isAtWar fact) lid-  lvl@Level{lxsize, lysize} <- getLevel $ blid body+  let lid = blid body+  lvl <- getLevel lid   let posHere = bpos body-      posHasFeature f pos = Tile.hasFeature cotile f (lvl `at` pos)       posHasItems pos = not $ EM.null $ lvl `atI` pos-      posLast = if distLast == 0 then posHere else posHere `shift` neg dirLast-      tryRunDist (dir, distNew)-        | accessibleDir cops lvl posHere dir =-          -- TODO: perhaps @abortWith report2?-          maybe abort (runDir leader) $-            runDisturbance-              posLast distLast sreport hs ms per smarkSuspect posHere-              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.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-    RunOpen    -> tryRun dirLast          -- run forward into the open space-    RunHub     -> abort                   -- stop and decide where to go-    RunCorridor (dirNext, _turn) ->       -- look ahead-      tryRun dirNext-      -- TODO: instead of a lookahead (does not work, since clients have-      -- limited knowledge), pass _turn similarly as in (dir, 1000)-      -- and decide next turn.-      -- TODO: perhaps boldpos can be handy here-      -- case runMode (posHere `shift` dirNext) dirNext dirEnterable lxsize of-      --   RunDeadEnd     -> tryRun dirNext  -- explore the dead end-      --   RunCorridor _  -> tryRun dirNext  -- follow the corridor-      --   RunOpen | turn -> abort           -- stop and decide when to turn-      --   RunHub  | turn -> abort           -- stop and decide when to turn-      --   RunOpen -> tryRunAndStop dirNext  -- no turn, get closer and stop-      --   RunHub  -> tryRunAndStop dirNext  -- no turn, get closer and stop+      posThere = posHere `shift` dir+  actorsThere <- getsState $ posToActors posThere lid+  let posLast = boldpos body+      dirLast = displacement posLast posHere+      -- This is supposed to work on unit vectors --- diagonal, as well as,+      -- vertical and horizontal.+      anglePos :: Point -> Vector -> RadianAngle -> Point+      anglePos pos d angle = shift pos (rotate angle d)+      -- We assume the tiles have not changes since last running step.+      -- If they did, we don't care --- running should be stopped+      -- because of the change of nearby tiles then (TODO).+      -- We don't take into account the two tiles at the rear of last+      -- surroundings, because the actor may have come from there+      -- (via a diagonal move) and if so, he may be interested in such tiles.+      -- If he arrived directly from the right or left, he is responsible+      -- for starting the run further away, if he does not want to ignore+      -- such tiles as the ones he came from.+      tileLast = lvl `at` posLast+      tileHere = lvl `at` posHere+      tileThere = lvl `at` posThere+      leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]+                   ++ map (anglePos posHere dir) [pi/2, 3*pi/4]+      rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]+                    ++ map (anglePos posHere dir) [-pi/2, -3*pi/4]+      leftForwardPosHere = anglePos posHere dir (pi/4)+      rightForwardPosHere = anglePos posHere dir (-pi/4)+      leftTilesLast = map (lvl `at`) leftPsLast+      rightTilesLast = map (lvl `at`) rightPsLast+      leftForwardTileHere = lvl `at` leftForwardPosHere+      rightForwardTileHere = lvl `at` rightForwardPosHere+      featAt = actionFeatures smarkSuspect . okind+      terrainChangeMiddle = null (Tile.causeEffects cotile tileThere)+                              -- step into; will stop next turn due to message+                            && featAt tileThere+                               `notElem` map featAt [tileLast, tileHere]+      terrainChangeLeft = featAt leftForwardTileHere+                          `notElem` map featAt leftTilesLast+      terrainChangeRight = featAt rightForwardTileHere+                           `notElem` map featAt rightTilesLast+      itemChangeLeft = posHasItems leftForwardPosHere+                       `notElem` map posHasItems leftPsLast+      itemChangeRight = posHasItems rightForwardPosHere+                        `notElem` map posHasItems rightPsLast+      check+        | not $ null actorsThere = return $ Left "actor in the way"+                       -- Actor in possibly another direction tnat original.+        | terrainChangeLeft = return $ Left "terrain change on the left"+        | terrainChangeRight = return $ Left "terrain change on the right"+        | itemChangeLeft = return $ Left "item change on the left"+        | itemChangeRight = return $ Left "item change on the right"+        | terrainChangeMiddle = return $ Left "terrain change in the middle"+        | otherwise = return $ Right dir+  check
Game/LambdaHack/Client/State.hs view
@@ -1,16 +1,19 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Server and client game state types and operations. module Game.LambdaHack.Client.State   ( StateClient(..), defStateClient, defHistory   , updateTarget, getTarget, updateLeader, sside-  , TgtMode(..), Target(..)+  , PathEtc, TgtMode(..), Target(..), RunParams(..), LastRecord   , toggleMarkVision, toggleMarkSmell, toggleMarkSuspect   ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Text (Text) import qualified Data.Text as T-import Game.LambdaHack.Common.Vector import qualified NLP.Miniutter.English as MU import qualified System.Random as R import System.Time@@ -27,8 +30,10 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State-import Control.Exception.Assert.Sugar+import Game.LambdaHack.Common.Vector  -- | Client state, belonging to a single faction. -- Some of the data, e.g, the history, carries over@@ -36,54 +41,93 @@ -- Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@. data StateClient = StateClient   { stgtMode     :: !(Maybe TgtMode)  -- ^ targeting mode-  , scursor      :: !(Maybe Point)    -- ^ cursor coordinates+  , scursor      :: !Target           -- ^ the common, cursor target   , seps         :: !Int              -- ^ a parameter of the tgt digital line-  , stargetD     :: !(EM.EnumMap ActorId Target)+  , stargetD     :: !(EM.EnumMap ActorId (Target, Maybe PathEtc))                                    -- ^ targets of our actors in the dungeon-  , srunning     :: !(Maybe (Vector, Int))-                                   -- ^ direction and distance of running+  , sexplored    :: !(ES.EnumSet LevelId)+                                   -- ^ the set of fully explored levels+  , sbfsD        :: !(EM.EnumMap ActorId+                        ( PointArray.Array BfsDistance+                        , Point, Int, Maybe [Point]) )+                                   -- ^ pathfinding distances for our actors+                                   --   and paths to their targets, if any+  , sselected    :: !(ES.EnumSet ActorId)+                                   -- ^ the set of currently selected actors+  , srunning     :: !(Maybe RunParams)+                                   -- ^ parameters of the current run, if any   , sreport      :: !Report        -- ^ current messages   , shistory     :: !History       -- ^ history of messages   , sundo        :: ![Atomic]      -- ^ atomic commands performed to date   , sdisco       :: !Discovery     -- ^ remembered item discoveries   , sfper        :: !FactionPers   -- ^ faction perception indexed by levels   , srandom      :: !R.StdGen      -- ^ current random generator-  , sconfigUI    :: !ConfigUI      -- ^ client config (including initial RNG)+  , sconfigUI    :: ConfigUI       -- ^ client config (including initial RNG)   , slastKey     :: !(Maybe K.KM)  -- ^ last command key pressed-  , _sleader     :: !(Maybe ActorId)  -- ^ selected actor+  , slastRecord  :: !LastRecord    -- ^ state of key sequence recording+  , slastPlay    :: ![K.KM]        -- ^ state of key sequence playback+  , slastCmd     :: !(Maybe CmdTakeTimeSer)+                                   -- ^ last command sent to the server+  , swaitTimes   :: !Int           -- ^ player just waited this many times+  , _sleader     :: !(Maybe ActorId)+                                   -- ^ current picked party leader   , _sside       :: !FactionId     -- ^ faction controlled by the client   , squit        :: !Bool          -- ^ exit the game loop   , sisAI        :: !Bool          -- ^ whether it's an AI client   , smarkVision  :: !Bool          -- ^ mark leader and party FOV   , smarkSmell   :: !Bool          -- ^ mark smell, if the leader can smell   , smarkSuspect :: !Bool          -- ^ mark suspect features+  , scurDifficulty :: !Int         -- ^ current game difficulty level   , sdebugCli    :: !DebugModeCli  -- ^ client debugging mode   }-  deriving (Show)+  deriving Show +type PathEtc = ([Point], (Point, Int))+ -- | Current targeting mode of a client.-data TgtMode =-    TgtExplicit { tgtLevelId :: !LevelId }-      -- ^ the player requested targeting mode explicitly-  | TgtAuto     { tgtLevelId :: !LevelId }-      -- ^ the mode was entered (and will be exited) automatically-  deriving (Show, Eq)+newtype TgtMode = TgtMode { tgtLevelId :: LevelId }+  deriving (Show, Eq, Binary)  -- | 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 !Bool+    -- ^ target an actor; cycle only trough seen foes, unless the flag is set+  | TEnemyPos !ActorId !LevelId !Point !Bool+    -- ^ last seen position of the targeted actor+  | TPoint !LevelId !Point              -- ^ target a concrete spot+  | TVector !Vector                     -- ^ target position relative to actor   deriving (Show, Eq) +-- | Parameters of the current run.+data RunParams = RunParams+  { runLeader  :: !ActorId         -- ^ the original leader from run start+  , runMembers :: ![ActorId]       -- ^ the list of actors that take part+  , runDist    :: !Int             -- ^ distance of the run so far+                                   --   (plus one, if multiple runners)+  , runStopMsg :: !(Maybe Text)    -- ^ message with the next stop reason+  , runInitDir :: !(Maybe Vector)  -- ^ the direction of the initial step+  }+  deriving (Show)++type LastRecord = ( [K.KM]  -- accumulated keys of the current command+                  , [K.KM]  -- keys of the rest of the recorded command batch+                  , Int     -- commands left to record for this batch+                  )+ -- | Initial game client state. defStateClient :: History -> ConfigUI -> FactionId -> Bool                -> StateClient defStateClient shistory sconfigUI _sside sisAI =   StateClient     { stgtMode = Nothing-    , scursor = Nothing+    , scursor = if sisAI+                then TVector $ Vector 30000 30000  -- invalid+                else TVector $ Vector 1 1  -- a step south-east     , seps = 0     , stargetD = EM.empty+    , sexplored = ES.empty+    , sbfsD = EM.empty+    , sselected = ES.empty     , srunning = Nothing     , sreport = emptyReport     , shistory@@ -93,6 +137,10 @@     , sconfigUI     , srandom = R.mkStdGen 42  -- will be set later     , slastKey = Nothing+    , slastRecord = ([], [], 0)+    , slastPlay = []+    , slastCmd = Nothing+    , swaitTimes = 0     , _sleader = Nothing  -- no heroes yet alive     , _sside     , squit = False@@ -100,6 +148,7 @@     , smarkVision = False     , smarkSmell = False     , smarkSuspect = False+    , scurDifficulty = 0     , sdebugCli = defDebugModeCli     } @@ -107,19 +156,23 @@ defHistory = do   dateTime <- getClockTime   let curDate = MU.Text $ T.pack $ calendarTimeToString $ toUTCTime dateTime-  return $ singletonHistory $ singletonReport-         $ makeSentence ["Human history log started on", curDate]+  return $! singletonHistory $ singletonReport+         $! makeSentence ["Human history log started on", curDate]  -- | Update target parameters within client state. updateTarget :: ActorId -> (Maybe Target -> Maybe Target) -> StateClient              -> StateClient-updateTarget aid f cli = cli { stargetD = EM.alter f aid (stargetD cli) }+updateTarget aid f cli =+  let f2 tp = case f $ fmap fst tp of+        Nothing -> Nothing+        Just tgt -> Just (tgt, Nothing)  -- reset path+  in cli {stargetD = EM.alter f2 aid (stargetD cli)}  -- | Get target parameters from client state. getTarget :: ActorId -> StateClient -> Maybe Target-getTarget aid cli = EM.lookup aid (stargetD cli)+getTarget aid cli = fmap fst $ EM.lookup aid $ stargetD cli --- | Update selected actor within state. Verify actor's faction.+-- | Update picked leader within state. Verify actor's faction. updateLeader :: ActorId -> State -> StateClient -> StateClient updateLeader leader s cli =   let side1 = bfid $ getActorBody leader s@@ -147,61 +200,81 @@     put scursor     put seps     put stargetD+    put sexplored+    put sselected     put srunning     put sreport     put shistory     put sundo     put sdisco     put (show srandom)-    put sconfigUI     put _sleader     put _sside     put sisAI     put smarkVision     put smarkSmell     put smarkSuspect-    put sdebugCli+    put scurDifficulty+    put sdebugCli  -- TODO: this is overwritten at once   get = do     stgtMode <- get     scursor <- get     seps <- get     stargetD <- get+    sexplored <- get+    sselected <- get     srunning <- get     sreport <- get     shistory <- get     sundo <- get     sdisco <- get     g <- get-    sconfigUI <- get     _sleader <- get     _sside <- get     sisAI <- get     smarkVision <- get     smarkSmell <- get     smarkSuspect <- get+    scurDifficulty <- get     sdebugCli <- get-    let sfper = EM.empty+    let sbfsD = EM.empty+        sfper = EM.empty         srandom = read g         slastKey = Nothing+        slastRecord = ([], [], 0)+        slastPlay = []+        slastCmd = Nothing+        swaitTimes = 0         squit = False-    return StateClient{..}+        sconfigUI = undefined+    return $! StateClient{..} -instance Binary TgtMode where-  put (TgtExplicit l) = putWord8 0 >> put l-  put (TgtAuto     l) = putWord8 1 >> put l+instance Binary RunParams where+  put RunParams{..} = do+    put runLeader+    put runMembers+    put runDist+    put runStopMsg+    put runInitDir   get = do-    tag <- getWord8-    case tag of-      0 -> liftM TgtExplicit get-      1 -> liftM TgtAuto get-      _ -> fail "no parse (TgtMode)"+    runLeader <- get+    runMembers <- get+    runDist<- get+    runStopMsg <- get+    runInitDir <- get+    return $! RunParams{..}  instance Binary Target where-  put (TEnemy a ll) = putWord8 0 >> put a >> put ll-  put (TPos pos) = putWord8 1 >> put pos+  put (TEnemy a permit) = putWord8 0 >> put a >> put permit+  put (TEnemyPos a lid p permit) =+    putWord8 1 >> put a >> put lid >> put p >> put permit+  put (TPoint lid p) = putWord8 2 >> put lid >> put p+  put (TVector v) = putWord8 3 >> put v   get = do     tag <- getWord8     case tag of       0 -> liftM2 TEnemy get get-      1 -> liftM TPos get+      1 -> liftM4 TEnemyPos get get get get+      2 -> liftM2 TPoint get get+      3 -> liftM TVector get       _ -> fail "no parse (Target)"
Game/LambdaHack/Client/Strategy.hs view
@@ -22,7 +22,8 @@  -- | Strategy is a monad. TODO: Can we write this as a monad transformer? instance Monad Strategy where-  return x = Strategy $ return $ uniformFreq "Strategy_return" [x]+  {-# INLINE return #-}+  return x = Strategy $ return $! uniformFreq "Strategy_return" [x]   m >>= f  = normalizeStrategy $ Strategy     [ toFreq name [ (p * q, b)                   | (p, a) <- runFrequency x@@ -36,16 +37,17 @@   fmap f (Strategy fs) = Strategy (map (fmap f) fs)  instance Applicative Strategy where-    pure  = return-    (<*>) = ap+  pure  = return+  (<*>) = ap  instance MonadPlus Strategy where   mzero = Strategy []+  {-# INLINE mplus #-}   mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)  instance Alternative Strategy where-    (<|>) = mplus-    empty = mzero+  (<|>) = mplus+  empty = mzero  normalizeStrategy :: Strategy a -> Strategy a normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs@@ -95,4 +97,4 @@  -- | Like 'return', but pick a name of the single frequency. returN :: Text -> a -> Strategy a-returN name x = Strategy $ return $ uniformFreq name [x]+returN name x = Strategy $ return $! uniformFreq name [x]
Game/LambdaHack/Client/StrategyAction.hs view
@@ -1,13 +1,16 @@ -- | AI strategy operations implemented with the 'Action' monad. module Game.LambdaHack.Client.StrategyAction-  ( targetStrategy, actionStrategy, visibleFoes+  ( targetStrategy, actionStrategy   ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES import Data.Function import Data.List import Data.Maybe+import Data.Ord import qualified Data.Traversable as Traversable  import Game.LambdaHack.Client.Action@@ -24,8 +27,8 @@ import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Random as Random import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State@@ -33,184 +36,294 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ActorKind+import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind as TileKind-import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency  -- | AI proposes possible targets for the actor. Never empty.-targetStrategy :: MonadClient m-               => ActorId -> [Ability] -> m (Strategy (Maybe Target))-targetStrategy aid factionAbilities = do-  btarget <- getsClient $ getTarget aid-  fper <- getsClient sfper-  reacquireTgt aid factionAbilities btarget fper--visibleFoes :: MonadActionRO m-            => ActorId -> FactionPers -> m [(ActorId, Actor)]-visibleFoes aid fper = do+targetStrategy :: forall m. MonadClient m+               => ActorId -> ActorId -> m (Strategy (Target, PathEtc))+targetStrategy oldLeader aid = do+  Kind.COps{ cotile=cotile@Kind.Ops{ouniqGroup}+           , coactor=Kind.Ops{okind}+           , cofaction=Kind.Ops{okind=fokind} } <- getsState scops+  modifyClient $ \cli -> cli {sbfsD = EM.delete aid (sbfsD cli)}   b <- getsState $ getActorBody aid+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  oldTgtUpdatedPath <- case mtgtMPath of+    Just (tgt, Just path) -> do+      mvalidPos <- aidTgtToPos aid (blid b) (Just tgt)+      if isNothing mvalidPos then return Nothing  -- wrong level+      else return $! case path of+        (p : q : rest, (goal, len)) ->+          if bpos b == p+          then Just (tgt, path)  -- no move last turn+          else if bpos b == q+               then Just (tgt, (q : rest, (goal, len - 1)))  -- step along path+               else Nothing  -- veered off the path+        ([p], (goal, _)) -> do+          assert (p == goal `blame` (aid, b, mtgtMPath)) skip+          if bpos b == p then+            Just (tgt, path)  -- goal reached; stay there picking up items+          else+            Nothing  -- somebody pushed us off the goal; let's target again+        ([], _) -> assert `failure` (aid, b, mtgtMPath)+    Just (_, Nothing) -> return Nothing  -- path invalidated, e.g. SpotActorA+    Nothing -> return Nothing  -- no target assigned yet+  lvl <- getLevel $ blid b   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 (actorSeesPos per aid . bpos . snd) foes--reacquireTgt :: MonadActionRO m-             => ActorId -> [Ability] -> Maybe Target -> FactionPers-             -> m (Strategy (Maybe Target))-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 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) <- 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 = 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-      closest :: Strategy (Maybe Target)-      closest =-        let distB = chessDist lxsize (bpos b)-            foeDist = map (\(_, body) -> distB (bpos body)) visFoes-            minDist | null foeDist = maxBound-                    | otherwise = minimum foeDist-            minFoes =-              filter (\(_, body) -> distB (bpos body) == minDist) visFoes-            minTargets = map (\(a, body) ->-                                Just $ TEnemy a $ bpos body) minFoes-            minTgtS = liftFrequency $ uniformFreq "closest" minTargets-        in minTgtS .| noFoes .| returN "TCursor" Nothing  -- never empty-      reacquire :: Maybe Target -> Strategy (Maybe Target)-      reacquire tgt =-        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 | actorSeesPos per aid l ->-                -- prefer visible (and alive) foes-                returN "TEnemy" $ Just $ TEnemy a l-              _ -> if null visFoes         -- prefer visible foes to positions-                      && bpos b /= ll      -- not yet reached the last pos-                   then returN "last known" $ Just $ TPos ll-                                           -- chase the last known pos-                   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 (asight mk) pos ->-            closest  -- no longer bumpable, even assuming no foes-          Just TPos{} | null visFoes -> returN "TPos" tgt-                                           -- nothing visible, go to pos-          Just TPos{} -> closest           -- prefer visible foes-          Nothing -> closest-  return $! reacquire btarget+  allFoes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b)+  dungeon <- getsState sdungeon+  -- TODO: we assume the actor eventually becomes a leader (or has the same+  -- set of abilities as the leader, anyway) and set his target accordingly.+  actorAbs <- actorAbilities aid (Just aid)+  let nearby = 10+      nearbyFoes = filter (\(_, body) ->+                             chessDist (bpos body) (bpos b) < nearby) allFoes+      unknownId = ouniqGroup "unknown space"+      -- TODO: make more common when weak ranged foes preferred, etc.+      focused = bspeed b < speedNormal+      canSmell = asmell $ okind $ bkind b+      setPath :: Target -> m (Strategy (Target, PathEtc))+      setPath tgt = do+        mpos <- aidTgtToPos aid (blid b) (Just tgt)+        let p = fromMaybe (assert `failure` (b, tgt)) mpos+        (bfs, mpath) <- getCacheBfsAndPath aid p+        case mpath of+          Nothing -> assert `failure` "new target unreachable" `twith` (b, tgt)+          Just path ->+            return $! returN "pickNewTarget"+              (tgt, ( bpos b : path+                    , (p, fromMaybe (assert `failure` mpath)+                          $ accessBfs bfs p) ))+      pickNewTarget :: m (Strategy (Target, PathEtc))+      pickNewTarget = do+        -- TODO: for foes, items, etc. consider a few nearby, not just one+        cfoes <- closestFoes aid+        case cfoes of+          (_, (a, _)) : _ -> setPath $ TEnemy a False+          [] -> do+            -- Tracking enemies is more important than exploring,+            -- and smelling actors are usually blind, so bad at exploring.+            -- TODO: prefer closer items to older smells+            smpos <- if canSmell+                     then closestSmell aid+                     else return []+            case smpos of+              [] -> do+                citems <- if Ability.Pickup `elem` actorAbs+                          then closestItems aid+                          else return []+                case citems of+                  [] -> do+                    upos <- closestUnknown aid+                    case upos of+                      Nothing -> do+                        ctriggers <- if Ability.Trigger `elem` actorAbs+                                     then closestTriggers Nothing False aid+                                     else return []+                        case ctriggers of+                          [] -> do+                            getDistant <-+                              rndToAction $ oneOf+                              $ [fmap maybeToList . furthestKnown]+                                ++ [ closestTriggers Nothing True+                                   | EM.size dungeon > 1 ]+                            kpos <- getDistant aid+                            case kpos of+                              [] -> return reject+                              p : _ -> setPath $ TPoint (blid b) p+                          p : _ -> setPath $ TPoint (blid b) p+                      Just p -> setPath $ TPoint (blid b) p+                  (_, (p, _)) : _ -> setPath $ TPoint (blid b) p+              (_, (p, _)) : _ -> setPath $ TPoint (blid b) p+      tellOthersNothingHere pos = do+        let f (tgt, _) = case tgt of+              TEnemyPos _ lid p _ -> p /= pos || lid /= blid b+              _ -> True+        modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)}+        pickNewTarget+      updateTgt :: Target -> PathEtc+                -> m (Strategy (Target, PathEtc))+      updateTgt oldTgt updatedPath = case oldTgt of+        TEnemy a _ -> do+          body <- getsState $ getActorBody a+          if not focused  -- prefers closer foes+             && not (null nearbyFoes)  -- foes nearby+             && a `notElem` map fst nearbyFoes  -- old one not close enough+             || blid body /= blid b  -- wrong level+          then pickNewTarget+          else if bpos body == fst (snd updatedPath)+               then return $! returN "TEnemy" (oldTgt, updatedPath)+                      -- The enemy didn't move since the target acquired.+                      -- If any walls were added that make the enemy+                      -- unreachable, AI learns that the hard way,+                      -- as soon as it bumps into them.+               else do+                 let p = bpos body+                 (bfs, mpath) <- getCacheBfsAndPath aid p+                 case mpath of+                   Nothing -> pickNewTarget  -- enemy became unreachable+                   Just path ->+                      return $! returN "TEnemy"+                        (oldTgt, ( bpos b : path+                                 , (p, fromMaybe (assert `failure` mpath)+                                       $ accessBfs bfs p) ))+        _ | not $ null nearbyFoes ->+          pickNewTarget  -- prefer close foes to anything+        TPoint lid pos -> do+          explored <- getsClient sexplored+          let allExplored = ES.size explored == EM.size dungeon+              abilityLeader = fAbilityLeader $ fokind $ gkind fact+              abilityOther = fAbilityOther $ fokind $ gkind fact+          if lid /= blid b  -- wrong level+             -- Below we check the target could not be picked again in+             -- pickNewTarget, and only in this case it is invalidated.+             -- This ensures targets are eventually reached (unless a foe+             -- shows up) and not changed all the time mid-route+             -- to equally interesting, but perhaps a bit closer targets,+             -- most probably already targeted by other actors.+             || (Ability.Pickup `notElem` actorAbs  -- closestItems+                 || EM.null (lvl `atI` pos))+                && (not canSmell  -- closestSmell+                    || pos == bpos b  -- in case server resends deleted smell+                    || let sml =+                             EM.findWithDefault timeZero pos (lsmell lvl)+                       in sml `timeAdd` timeNegate (ltime lvl) <= timeZero)+                && let t = lvl `at` pos+                   in if ES.notMember lid explored+                      then  -- closestUnknown+                        t /= unknownId+                        && not (Tile.isSuspect cotile t)+                      else  -- closestTriggers+                        -- Try to kill that very last enemy for his loot before+                        -- leaving the level or dungeon.+                        not (null allFoes)+                        || -- If all explored, escape/block escapes.+                           (Ability.Trigger `notElem` actorAbs+                            || not (Tile.isEscape cotile t && allExplored))+                           -- The next case is stairs in closestTriggers.+                           -- We don't determine if the stairs are interesting+                           -- (this changes with time), but allow the actor+                           -- to reach them and then retarget.+                           && not (pos /= bpos b && Tile.isStair cotile t)+                           -- The remaining case is furthestKnown. This is+                           -- always an unimportant target, so we forget it+                           -- if the actor is stuck (could move, but waits).+                           && let isStuck =+                                    waitedLastTurn b+                                    && (oldLeader == aid+                                        || abilityLeader == abilityOther)+                              in not (pos /= bpos b+                                      && not isStuck+                                      && allExplored)+          then pickNewTarget+          else return $! returN "TPoint" (oldTgt, updatedPath)+        _ | not $ null allFoes ->+          pickNewTarget  -- new likely foes location spotted, forget the old+        TEnemyPos _ lid p _ ->+          -- Chase last position even if foe hides or dies,+          -- to find his companions, loot, etc.+          if lid /= blid b  -- wrong level+          then pickNewTarget+          else if p == bpos b+               then tellOthersNothingHere p+               else return $! returN "TEnemyPos" (oldTgt, updatedPath)+        TVector{} -> pickNewTarget+  case oldTgtUpdatedPath of+    Just (oldTgt, updatedPath) -> updateTgt oldTgt updatedPath+    Nothing -> pickNewTarget --- | AI strategy based on actor's sight, smell, intelligence, etc. Never empty.-actionStrategy :: MonadClient m-               => ActorId -> [Ability] -> m (Strategy CmdSerTakeTime)-actionStrategy aid factionAbilities = do+-- | AI strategy based on actor's sight, smell, intelligence, etc.+-- Never empty.+actionStrategy :: forall m. MonadClient m+               => ActorId -> m (Strategy CmdTakeTimeSer)+actionStrategy aid = do+  cops <- getsState scops   disco <- getsClient sdisco   btarget <- getsClient $ getTarget aid-  proposeAction disco aid factionAbilities btarget--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+  Actor{bpos, blid} <- getsState $ getActorBody aid+  bitems <- getsState $ getActorItem aid+  lootItems <- getsState $ getFloorItem blid bpos   lvl <- getLevel blid-  let mk = okind bkind-      (fpos, mfAid) =+  mleader <- getsClient _sleader+  actorAbs <- actorAbilities aid mleader+  let 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+          Just (TEnemy foeAid _) -> Just foeAid+          _ -> Nothing       foeVisible = isJust mfAid       lootHere x = not $ EM.null $ lvl `atI` x-      actorAbilities = acanDo mk `intersect` factionAbilities+      lootIsWeapon = isJust $ strongestSword cops lootItems+      hasNoWeapon = isNothing $ strongestSword cops bitems       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+      (prefix, rest)    = break isDistant actorAbs       (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 -> m (Frequency CmdTakeTimeSer)       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"-                                          `twith` (ab, distant, actorAbilities)-      chaseFreq :: MonadActionRO m => m (Frequency CmdSerTakeTime)+      aFrequency Ability.Ranged  = rangedFreq aid+      aFrequency Ability.Tools   = if not foeVisible then return mzero+                                   else toolsFreq disco aid+      aFrequency Ability.Chase   = if not foeVisible then return mzero+                                   else chaseFreq+      aFrequency ab              = assert `failure` "unexpected ability"+                                          `twith` (ab, distant, actorAbs)+      chaseFreq :: MonadActionRO m => m (Frequency CmdTakeTimeSer)       chaseFreq = do-        st <- chase aid (fpos, foeVisible)-        return $ scaleFreq 30 $ bestVariant st-      aStrategy :: MonadActionRO m => Ability -> m (Strategy CmdSerTakeTime)+        st <- chase aid True+        return $! scaleFreq 30 $ bestVariant st+      aStrategy :: Ability -> m (Strategy CmdTakeTimeSer)       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 Ability.Heal   = return reject  -- TODO+      aStrategy Ability.Flee   = return reject  -- TODO+      aStrategy Ability.Melee | foeVisible = melee aid+      aStrategy Ability.Melee  = return reject+      aStrategy Ability.Displace = displace aid+      aStrategy Ability.Pickup | not foeVisible && lootHere bpos+                                 || hasNoWeapon && lootIsWeapon = pickup aid+      aStrategy Ability.Pickup = return reject+      aStrategy Ability.Wander = chase aid False       aStrategy ab             = assert `failure` "unexpected ability"-                                        `twith`(ab, actorAbilities)+                                        `twith`(ab, actorAbs)       sumS abis = do         fs <- mapM aStrategy abis-        return $ msum fs+        return $! msum fs       sumF abis = do         fs <- mapM aFrequency abis-        return $ msum fs+        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+  return $! sumPrefix .| comDistant .| sumSuffix+            -- Wait until friends sidestep; ensures 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 CmdSerTakeTime+waitBlockNow :: ActorId -> Strategy CmdTakeTimeSer waitBlockNow aid = returN "wait" $ WaitSer aid --- | Strategy for dumb missiles.-track :: MonadActionRO m => ActorId -> m (Strategy CmdSerTakeTime)+-- | Strategy for a dumb missile or a strongly hurled actor.+track :: MonadActionRO m => ActorId -> m (Strategy CmdTakeTimeSer) 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" `twith` (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+  btrajectory <- getsState $ btrajectory . getActorBody aid+  return $! if isNothing btrajectory+            then reject+            else returN "SetTrajectorySer" $ SetTrajectorySer aid  -- TODO: (most?) animals don't pick up. Everybody else does.-pickup :: MonadActionRO m => ActorId -> m (Strategy CmdSerTakeTime)+-- TODO: pick up best weapons first+pickup :: MonadActionRO m => ActorId -> m (Strategy CmdTakeTimeSer) pickup aid = do   body@Actor{bpos, blid} <- getsState $ getActorBody aid   lvl <- getLevel blid@@ -219,107 +332,191 @@     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+      return $! case assignLetter iid l body of+        Just _ -> returN "pickup" $ PickupSer aid iid k         Nothing -> returN "pickup" $ WaitSer aid  -- TODO-  return actionPickup+  return $! actionPickup  -- 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)+melee :: MonadClient m => ActorId -> m (Strategy CmdTakeTimeSer)+melee aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ \s -> sfactionD s EM.! bfid b+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  str1 <- case mtgtMPath of+    Just (_, Just (_ : q : _, (goal, _))) -> do+      -- We prefer the goal (e.g., when no accessible, but adjacent),+      -- but accept @q@ even if it's only a blocking enemy position.+      let maim = if adjacent (bpos b) goal then Just goal+                 else if adjacent (bpos b) q then Just q+                 else Nothing  -- MeleeDistant+      mBlocker <- case maim of+        Nothing -> return Nothing+        Just aim -> getsState $ posToActor aim (blid b)+      case mBlocker of+        Just ((aid2, _), _) -> do+          -- No problem if there are many projectiles at the spot. We just+          -- attack the first one.+          body2 <- getsState $ getActorBody aid2+          if isAtWar fact (bfid body2) then+            return $! returN "melee in the way" (MeleeSer aid aid2)+          else return reject+        Nothing -> return reject+    _ -> return reject  -- probably no path to the foe, if any+  -- TODO: depending on actor kind, sometimes move this in strategy+  -- to a place after movement+  if not $ nullStrategy str1 then return str1 else do+    Level{lxsize, lysize} <- getLevel $ blid b+    allFoes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b)+    let vic = vicinity lxsize lysize $ bpos b+        adjFoes = filter ((`elem` vic) . bpos . snd) allFoes+        -- TODO: prioritize somehow+        freq = uniformFreq "melee adjacent" $ map (MeleeSer aid . fst) adjFoes+    return $ liftFrequency freq  -- Fast monsters don't pay enough attention to features.-triggerFreq :: MonadActionRO m-            => ActorId -> m (Frequency CmdSerTakeTime)+triggerFreq :: MonadClient m => ActorId -> m (Frequency CmdTakeTimeSer) 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+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  b <- getsState $ getActorBody aid+  fact <- getsState $ \s -> sfactionD s EM.! bfid b+  lvl <- getLevel $ blid b+  unexploredD <- unexploredDepth+  s <- getState+  let unexploredCurrent = ES.notMember (blid b) explored+      allExplored = ES.size explored == EM.size dungeon+      isHero = isHeroFact cops fact+      t = lvl `at` bpos b       feats = TileKind.tfeature $ okind t       ben feat = case feat of-        F.Cause Effect.Escape | spawn -> 0  -- spawners lose if they escape+        F.Cause (Effect.Ascend k) ->  -- change levels sensibly, in teams+          let expBenefit =+                if unexploredCurrent+                then 0  -- don't leave the level until explored+                else if unexploredD (signum k) (blid b)+                then 1000+                else if unexploredD (- signum k) (blid b)+                then 0  -- wait for stairs in the opposite direciton+                else if lescape lvl+                then 0  -- all explored, stay on the escape level+                else 2  -- no escape anywhere, switch levels occasionally+              (lid2, pos2) = whereTo (blid b) (bpos b) k dungeon+              actorsThere = posToActors pos2 lid2 s+          in if boldpos b == bpos b   -- probably used stairs last turn+                && boldlid b == lid2  -- in the opposite direction+             then 0  -- avoid trivial loops (pushing, being pushed, etc.)+             else case actorsThere of+               [] -> expBenefit+               [((_, body), _)] | not (bproj body)+                                  && isAtWar fact (bfid body) ->+                 min 1 expBenefit  -- push the enemy if no better option+               _ -> 0  -- projectiles or non-enemies+        F.Cause ef@Effect.Escape{} ->+          -- Only heroes escape but they first explore all for high score.+          if not (isHero && allExplored) then 0 else effectToBenefit cops b ef         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 ]+  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+rangedFreq :: MonadClient m+           => ActorId -> m (Frequency CmdTakeTimeSer)+rangedFreq aid = do   cops@Kind.COps{ coactor=Kind.Ops{okind}-                , coitem=Kind.Ops{okind=iokind}+                , coitem=coitem@Kind.Ops{okind=iokind}                 , corule-                , cotile                 } <- getsState scops+  btarget <- getsClient $ getTarget aid   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+  mfpos <- aidTgtToPos aid blid btarget+  case (btarget, mfpos) of+    (Just TEnemy{}, Just fpos) -> do+      disco <- getsClient sdisco+      itemD <- getsState sitemD+      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+      (steps, eps) <- makePath b fpos+      let permitted = (if aiq mk >= 10 then ritemProject else ritemRanged)+                      $ Kind.stdRuleset corule+          itemReaches item =+            let lingerPercent = isLingering coitem disco item+                toThrow = maybe 0 (itoThrow . iokind) $ jkind disco item+                speed = speedFromWeight (jweight item) toThrow+                range = rangeFromSpeed speed+                totalRange = lingerPercent * range `div` 100+            in steps <= totalRange  -- probably enough range+                 -- TODO: make sure itoThrow identified after a single throw+          getItemB iid =+            fromMaybe (assert `failure` "item body not found"+                              `twith` (iid, itemD)) $ EM.lookup iid itemD+          throwFreq bag multi container =+            [ (- benefit * multi,+              ProjectSer aid fpos eps iid (container iid))+            | (iid, i) <- map (\iid -> (iid, getItemB iid))+                          $ 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+            , itemReaches i ]+          freq =+            if asight mk  -- ProjectBlind+               && not foesAdj  -- ProjectBlockFoes+               -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain+               -- and no actors or obstracles along the path+               && steps == chessDist bpos fpos+            then toFreq "throwFreq"+                 $ throwFreq bbag 4 (actorContainer aid binv)+                   ++ throwFreq tis 8 (const $ CFloor blid bpos)+            else toFreq "throwFreq: not possible" []+      return $! freq+    _ -> return $! toFreq "throwFreq: no enemy target" []++-- TODO: finetune eps+-- | Counts the number of steps until the projectile would hit+-- an actor or obstacle.+makePath :: MonadClient m => Actor -> Point -> m (Int, Int)+makePath body fpos = do+  cops <- getsState scops+  lvl@Level{lxsize, lysize} <- getLevel (blid body)+  bs <- getsState $ actorNotProjList (const True) (blid body)   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  -- ProjectBlockFoes-           && asight mk-           && posClear pos1  -- ProjectBlockTerrain-           && unoccupied as pos1  -- ProjectBlockActor-        then throwFreq bbag 3 (actorContainer aid binv)-             ++ throwFreq tis 6 (const $ CFloor blid bpos)-        else []-      _ -> []  -- ProjectAimOnself+      mbl = bla lxsize lysize eps (bpos body) fpos+  case mbl of+    Just bl@(pos1:_) -> do+      let noActor p = any ((== p) . bpos) bs+      case break noActor bl of+        (flies, hits : _) -> do+          let blRest = flies ++ [hits]+              blZip = zip (bpos body : blRest) blRest+              blAccess = takeWhile (uncurry $ accessible cops lvl) blZip+          mab <- getsState $ posToActor pos1 (blid body)+          if maybe True (bproj . snd . fst) mab then+            return $ (length blAccess, eps)+          else return (0, eps)  -- ProjectBlockActor+        _ -> assert `failure` (body, fpos, bl)+    Just [] -> assert `failure` (body, fpos)+    Nothing -> return (0, eps)  -- ProjectAimOnself  -- Tools use requires significant intelligence and sometimes literacy. toolsFreq :: MonadActionRO m-          => Discovery -> ActorId -> m (Frequency CmdSerTakeTime)+          => Discovery -> ActorId -> m (Frequency CmdTakeTimeSer) toolsFreq disco aid = do   cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops   b@Actor{bkind, bpos, blid, bbag, binv} <- getsState $ getActorBody aid@@ -340,152 +537,97 @@                   Just _ki -> effectToBenefit cops b $ jeffect i         , benefit > 0         , jsymbol i `elem` mastered ]-  return $ toFreq "useFreq" $+  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 :: 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 =-            let tolerance | adjacent lxsize bpos fpos = 0-                          | otherwise = 1-                foeDir = towards lxsize bpos fpos-            in only (\x -> euclidDistSq lxsize foeDir x <= tolerance)-      in if fpos == bpos-         then reject-         else towardsFoe-              $ if foeVisible-                then moveClear  -- enemies in sight, don't waste time for doors-                     .| moveOpenable-                else moveOpenable  -- no enemy in sight, explore doors-                     .| moveClear-    Nothing ->-      let smells =-            map (map fst)-            $ groupBy ((==) `on` snd)-            $ sortBy (flip compare `on` snd)-            $ filter (\(_, sm) -> sm > timeZero)-            $ map (\x ->-                      let sml = EM.findWithDefault-                                  timeZero (bpos `shift` x) lsmell-                      in (x, sml `timeAdd` timeNegate ltime))-                sensible-      in asmell mk .=> foldr ((.|)-                              . liftFrequency-                              . uniformFreq "smell k") reject smells-         .| moveOpenable  -- no enemy in sight, explore doors-         .| moveClear- 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 aid s-  mk = okind bkind-  lootHere x = not $ EM.null $ lvl `atI` x-  onlyLoot = onlyMoves lootHere-  interestHere x = let t = lvl `at` x-                       ts = map (lvl `at`) $ vicinity lxsize lysize x-                   in Tile.hasFeature cotile F.Exit t-                      -- Blind actors tend to reveal/forget repeatedly.-                      || asight mk && Tile.hasFeature cotile F.Suspect t-                      -- Lit indirectly. E.g., a room entrance.-                      || (not (Tile.hasFeature cotile F.Lit t)-                          && (x == bpos || accessible cops lvl x bpos)-                          && any (Tile.hasFeature cotile F.Lit) ts)-  onlyInterest = onlyMoves interestHere-  bdirAI | bpos == boldpos = Nothing-         | otherwise = Just $ towards lxsize boldpos bpos-  onlyKeepsDir k =-    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-    .| aiq mk > 10 .=> onlyKeepsDir 1 moveRandomly-    .| aiq mk > 5  .=> onlyKeepsDir 2 moveRandomly-    .| onlyKeepsDir_9 moveRandomly-  interestFreq | interestHere bpos =-    -- Don't detour towards an interest if already on one.-    mzero-               | otherwise =-    -- Prefer interests, but don't exclude other focused moves.-    scaleFreq 10 $ bestVariant $ onlyInterest $ onlyKeepsDir 2 moveRandomly-  interestIQFreq = interestFreq `mplus` bestVariant moveIQ-  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-               .| liftFrequency interestIQFreq-               .| moveIQ  -- @bestVariant moveIQ@ may be excluded elsewhere-               .| moveRandomly-  onlyMoves :: (Point -> Bool) -> Strategy Vector -> Strategy Vector-  onlyMoves p = only (\x -> p (bpos `shift` x))-  moveRandomly :: Strategy Vector-  moveRandomly = liftFrequency $ uniformFreq "moveRandomly" sensible-  accessibleHere = accessible cops lvl bpos-  fact = sfactionD s EM.! bfid-  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 (asight mk) l)-  sensible = filter (isSensible . (bpos `shift`)) (moves lxsize)--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+displace :: MonadClient m => ActorId -> m (Strategy CmdTakeTimeSer)+displace aid = do+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  str <- case mtgtMPath of+    Just (_, Just (p : q : _, _)) -> displaceTowards aid p q+    _ -> return reject  -- goal reached+  Traversable.mapM (moveOrRunAid True aid) str -chase :: MonadActionRO m-      => ActorId -> (Point, Bool) -> m (Strategy CmdSerTakeTime)-chase aid foe@(_, foeVisible) = do+-- TODO: perhaps modify target when actually moving, not when+-- producing the strategy, even if it's a unique choice in this case.+displaceTowards :: MonadClient m+                => ActorId -> Point -> Point -> m (Strategy Vector)+displaceTowards aid source target = 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.-  let mFoe = Just foe-      fight = not foeVisible  -- don't pick fights if the real foe is close-  s <- getState-  str <- moveStrategy cops aid s mFoe-  if fight-    then Traversable.mapM (moveRunAid False aid) str-    else Traversable.mapM (moveRunAid True aid) str+  b <- getsState $ getActorBody aid+  assert (source == bpos b && adjacent source target) skip+  lvl <- getsState $ (EM.! blid b) . sdungeon+  if boldpos b /= target -- avoid trivial loops+     && accessible cops lvl source target then do+    mBlocker <- getsState $ posToActors target (blid b)+    case mBlocker of+      [] -> return reject+      [((aid2, _), _)] -> do+        mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD+        case mtgtMPath of+          Just (tgt, Just (p : q : rest, (goal, len)))+            | q == source && p == target -> do+              let newTgt = Just (tgt, Just (q : rest, (goal, len - 1)))+              modifyClient $ \cli ->+                cli {stargetD = EM.alter (const $ newTgt) aid (stargetD cli)}+              return $! returN "displace friend" $ displacement source target+          Just _ -> return reject+          Nothing ->+            return $! returN "displace other" $ displacement source target+      _ -> return reject  -- many projectiles, can't displace+  else return reject -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.-  let mFoe = Nothing-  s <- getState-  str <- moveStrategy cops aid s mFoe-  Traversable.mapM (moveRunAid False aid) str+chase :: MonadClient m => ActorId -> Bool -> m (Strategy CmdTakeTimeSer)+chase aid foeVisible = do+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  str <- case mtgtMPath of+    Just (_, Just (p : q : _, (goal, _))) -> moveTowards aid p q goal+    _ -> return reject  -- goal reached+  if foeVisible  -- don't pick fights, but displace, if the real foe is close+    then Traversable.mapM (moveOrRunAid True aid) str+    else Traversable.mapM (moveOrRunAid False aid) str +moveTowards :: MonadClient m+            => ActorId -> Point -> Point -> Point -> m (Strategy Vector)+moveTowards aid source target goal = do+  cops@Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops+  b <- getsState $ getActorBody aid+  assert (source == bpos b && adjacent source target) skip+  lvl <- getsState $ (EM.! blid b) . sdungeon+  fact <- getsState $ (EM.! bfid b) . sfactionD+  friends <- getsState $ actorList (not . isAtWar fact) $ blid b+  let _mk = okind $ bkind b+      noFriends = unoccupied friends+      -- Was:+      -- noFriends | asight mk = unoccupied friends+      --           | otherwise = const True+      -- but this should be implemented on the server or, if not,+      -- restricted to AI-only factions (e.g., animals).+      -- Otherwise human players are tempted to tweak their AI clients+      -- (as soon as we let them register their AI clients with the server).+      accessibleHere = accessible cops lvl source+      bumpableHere p =+        let t = lvl `at` p+        in Tile.isOpenable cotile t || Tile.isSuspect cotile t+      enterableHere p = accessibleHere p || bumpableHere p+  if noFriends target && enterableHere target then+    return $! returN "moveTowards adjacent" $ displacement source target+  else do+    let goesBack v = v == displacement source (boldpos b)+        nonincreasing p = chessDist source goal >= chessDist p goal+        isSensible p = nonincreasing p && noFriends p && enterableHere p+        sensible = [ ((goesBack v, chessDist p goal), v)+                   | v <- moves, let p = source `shift` v, isSensible p ]+        sorted = sortBy (comparing fst) sensible+        groups = map (map snd) $ groupBy ((==) `on` fst) sorted+        freqs = map (liftFrequency . uniformFreq "moveTowards") groups+    return $! foldr (.|) reject freqs+ -- | Actor moves or searches or alters or attacks. Displaces if @run@.-moveRunAid :: MonadActionRO m-           => Bool -> ActorId -> Vector -> m CmdSerTakeTime-moveRunAid run source dir = do+moveOrRunAid :: MonadActionRO m+             => Bool -> ActorId -> Vector -> m CmdTakeTimeSer+moveOrRunAid run source dir = do   cops@Kind.COps{cotile} <- getsState scops   sb <- getsState $ getActorBody source   let lid = blid sb@@ -497,33 +639,35 @@   -- 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+  tgts <- getsState $ posToActors tpos lid+  case tgts of+    [((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+        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+        return $! MeleeSer source target+    ((target, _), _) : _ ->  -- can be a foe, as well as a friend (e.g., proj.)+      -- No problem if there are many projectiles at the spot. We just+      -- attack the first one.       -- Attacking does not require full access, adjacency is enough.-      return $ MeleeSer source target-    Nothing -> do  -- move or search or alter+      return $! MeleeSer source target+    [] -> do  -- move or search or alter       if accessible cops lvl spos tpos then         -- Movement requires full access.-        return $ MoveSer source dir+        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" `twith` (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+      else if not (Tile.isWalkable cotile t)  -- not implied+              && (Tile.isSuspect cotile t+                  || Tile.isOpenable cotile t+                  || Tile.isClosable cotile t+                  || Tile.isChangeable cotile t) then         -- No access, so search and/or alter the tile.-        return $ AlterSer source tpos Nothing+        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"@@ -535,7 +679,6 @@ 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)@@ -548,6 +691,5 @@     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+    Effect.Ascend{} -> 0               -- change levels sensibly, in teams+    Effect.Escape{} -> 10000           -- AI wants to win; spawners to guard
Game/LambdaHack/Common/Ability.hs view
@@ -10,10 +10,11 @@ -- that any actor picks each turn, depending on the actor's characteristics -- and his environment. data Ability =-    Track   -- ^ move along a set path, if any, meleeing any opponents+    Track   -- ^ move along a set trajectory, if any, meleeing any opponents   | Heal    -- ^ heal if almost dead   | Flee    -- ^ flee if almost dead   | Melee   -- ^ melee target+  | Displace  -- ^ switch places with a friend   | Pickup  -- ^ gather items, if no foes visible   | Trigger -- ^ trigger a feature   | Ranged  -- ^ attack the visible target opponent at range, some of the time
Game/LambdaHack/Common/Action.hs view
@@ -10,9 +10,7 @@   , serverSaveName   ) where -import Control.Monad.Writer.Strict (WriterT, lift) import qualified Data.EnumMap.Strict as EM-import Data.Monoid  import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.Faction@@ -24,13 +22,6 @@   getState    :: m State   getsState   :: (State -> a) -> m a -instance (Monoid a, MonadActionRO m) => MonadActionRO (WriterT a m) where-  getState    = lift getState-  getsState   = lift . getsState--instance MonadActionRO m => Show (WriterT a m b) where-  show _ = "an action"- class MonadActionRO m => MonadAction m where   modifyState :: (State -> State) -> m ()   putState    :: State -> m ()@@ -48,7 +39,7 @@ nUI :: MonadActionRO m => m Int nUI = do   factionD <- getsState sfactionD-  return $ length $ filter (playerUI . gplayer) $ EM.elems factionD+  return $! length $ filter (playerUI . gplayer) $ EM.elems factionD  serverSaveName :: String serverSaveName = "server.sav"
Game/LambdaHack/Common/Actor.hs view
@@ -11,9 +11,10 @@   , ItemBag, ItemInv, InvChar(..), ItemDict, ItemRev   , allLetters, assignLetter, letterLabel, letterRange, rmFromBag     -- * Assorted-  , ActorDict, smellTimeout, mapActorItems_+  , ActorDict, smellTimeout, mapActorItems_, checkAdjacent   ) where +import Control.Exception.Assert.Sugar import Data.Binary import Data.Char import qualified Data.EnumMap.Strict as EM@@ -37,7 +38,6 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ActorKind-import Control.Exception.Assert.Sugar  -- | A unique identifier of an actor in the dungeon. newtype ActorId = ActorId Int@@ -52,24 +52,25 @@ -- they are usually modified temporarily, but tend to return -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor-  { bkind   :: !(Kind.Id ActorKind)  -- ^ the kind of the actor-  , 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-  , boldpos :: !Point                -- ^ previous position-  , blid    :: !LevelId              -- ^ current level-  , bbag    :: !ItemBag              -- ^ items carried-  , binv    :: !ItemInv              -- ^ map from letters to items-  , bletter :: !InvChar              -- ^ next inventory letter-  , btime   :: !Time                 -- ^ absolute time of next action-  , bwait   :: !Time                 -- ^ last bracing expires at this time-  , bfid    :: !FactionId            -- ^ to which faction the actor belongs-  , bproj   :: !Bool                 -- ^ is a projectile? (shorthand only,-                                     --   this can be deduced from bkind)+  { bkind       :: !(Kind.Id ActorKind)  -- ^ the kind of the actor+  , bsymbol     :: !Char                 -- ^ individual map symbol+  , bname       :: !Text                 -- ^ individual name+  , bcolor      :: !Color.Color          -- ^ individual map color+  , bspeed      :: !Speed                -- ^ individual speed+  , bhp         :: !Int                  -- ^ current hit points+  , btrajectory :: !(Maybe [Vector])     -- ^ trajectory the actor must travel+  , bpos        :: !Point                -- ^ current position+  , boldpos     :: !Point                -- ^ previous position+  , blid        :: !LevelId              -- ^ current level+  , boldlid     :: !LevelId              -- ^ previous level+  , bbag        :: !ItemBag              -- ^ items carried+  , binv        :: !ItemInv              -- ^ map from letters to items+  , bletter     :: !InvChar              -- ^ next inventory letter+  , btime       :: !Time                 -- ^ absolute time of next action+  , bwait       :: !Bool                 -- ^ is the actor waiting right now?+  , bfid        :: !FactionId            -- ^ faction the actor belongs to+  , bproj       :: !Bool                 -- ^ is a projectile? (shorthand only,+                                         --   this can be deduced from bkind)   }   deriving (Show, Eq, Ord) @@ -84,8 +85,9 @@   -- 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)+      -- On level 1, First 2 monsters appear fast.+      scaledDepth = 5 * n `div` depth+  in chance $ 1%(fromIntegral (100 * (numMonsters - scaledDepth)) `max` 10)  -- | The part of speech describing the actor. partActor :: Actor -> MU.Part@@ -97,13 +99,14 @@ 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 btrajectory bpos blid btime               bfid bproj =-  let boldpos = bpos+  let boldpos = Point 0 0  -- make sure /= bpos, to tell it didn't switch level+      boldlid = blid       bbag    = EM.empty       binv    = EM.empty       bletter = InvChar 'a'-      bwait   = timeZero+      bwait   = False   in Actor{..}  -- | Add time taken by a single step at the actor's current speed.@@ -113,17 +116,13 @@       delta = ticksPerMeter speed   in timeAdd time delta --- | 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 b time = time <= bwait b+-- | Whether an actor is braced for combat this clip.+braced :: Actor -> Bool+braced b = 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+-- | The actor waited last turn.+waitedLastTurn :: Actor -> Bool+waitedLastTurn b = bwait b  -- | Checks for the presence of actors in a position. -- Does not check if the tile is walkable.@@ -228,6 +227,9 @@   let is = EM.assocs bbag   mapM_ (uncurry f) is +checkAdjacent :: Actor -> Actor -> Bool+checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb)+ instance Binary Actor where   put Actor{..} = do     put bkind@@ -236,10 +238,11 @@     put bcolor     put bspeed     put bhp-    put bpath+    put btrajectory     put bpos     put boldpos     put blid+    put boldlid     put bbag     put binv     put bletter@@ -254,10 +257,11 @@     bcolor <- get     bspeed <- get     bhp <- get-    bpath <- get+    btrajectory <- get     bpos <- get     boldpos <- get     blid <- get+    boldlid <- get     bbag <- get     binv <- get     bletter <- get@@ -265,4 +269,4 @@     bwait <- get     bfid <- get     bproj <- get-    return Actor{..}+    return $! Actor{..}
Game/LambdaHack/Common/ActorState.hs view
@@ -2,13 +2,17 @@ -- but not the 'Action' type. -- TODO: Document an export list after it's rewritten according to #17. module Game.LambdaHack.Common.ActorState-  ( actorAssocs, actorList, actorNotProjAssocs, actorNotProjList+  ( actorAssocsLvl, actorAssocs, actorList+  , actorNotProjAssocsLvl, actorNotProjAssocs, actorNotProjList   , calculateTotal, nearbyFreePoints, whereTo-  , posToActor, getItemBody, memActor, getActorBody, updateActorBody-  , getActorItem, getActorBag, actorContainer, getActorInv+  , posToActors, posToActor, getItemBody, memActor+  , getActorBody, updateActorBody+  , getActorItem, getFloorItem, getActorBag+  , actorContainer, actorContainerB, getActorInv   , tryFindHeroK, foesAdjacent   ) where +import Control.Exception.Assert.Sugar import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES@@ -17,55 +21,67 @@  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.TileKind-import Control.Exception.Assert.Sugar -actorAssocs :: (FactionId -> Bool) -> LevelId -> State-            -> [(ActorId, Actor)]-actorAssocs p lid s =-  mapMaybe (\aid -> let actor = sactorD s EM.! aid+actorAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict+               -> [(ActorId, Actor)]+actorAssocsLvl p lvl actorD =+  mapMaybe (\aid -> let actor = actorD EM.! aid                     in if p (bfid actor)                        then Just (aid, actor)                        else Nothing)-  $ concat $ EM.elems $ lprio $ sdungeon s EM.! lid+  $ concat $ EM.elems $ lprio lvl +actorAssocs :: (FactionId -> Bool) -> LevelId -> State+            -> [(ActorId, Actor)]+actorAssocs p lid s =+  actorAssocsLvl p (sdungeon s EM.! lid) (sactorD s)+ actorList :: (FactionId -> Bool) -> LevelId -> State           -> [Actor] actorList p lid s = map snd $ actorAssocs p lid s -actorNotProjAssocs :: (FactionId -> Bool) -> LevelId -> State-                   -> [(ActorId, Actor)]-actorNotProjAssocs p lid s =-  mapMaybe (\aid -> let actor = sactorD s EM.! aid+actorNotProjAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict+                      -> [(ActorId, Actor)]+actorNotProjAssocsLvl p lvl actorD =+  mapMaybe (\aid -> let actor = actorD EM.! aid                     in if not (bproj actor) && p (bfid actor)                        then Just (aid, actor)                        else Nothing)-  $ concat $ EM.elems $ lprio $ sdungeon s EM.! lid+  $ concat $ EM.elems $ lprio lvl +actorNotProjAssocs :: (FactionId -> Bool) -> LevelId -> State+                   -> [(ActorId, Actor)]+actorNotProjAssocs p lid s =+  actorNotProjAssocsLvl p (sdungeon s EM.! lid) (sactorD s)+ actorNotProjList :: (FactionId -> Bool) -> LevelId -> State                  -> [Actor] actorNotProjList p lid s = map snd $ actorNotProjAssocs p lid s --- | Finds an actor at a position on the current level. Perception irrelevant.-posToActor :: Point -> LevelId -> State -> Maybe ActorId-posToActor pos lid s =-  let l = posToActors pos lid s-  in assert (length l <= 1 `blame` "many actors at the same position" `twith` l)-     $ listToMaybe l+-- | Finds an actor at a position on the current level.+posToActor :: Point -> LevelId -> State+           -> Maybe ((ActorId, Actor), [(ItemId, Item)])+posToActor pos lid s = listToMaybe $ posToActors pos lid s -posToActors :: Point -> LevelId -> State -> [ActorId]+posToActors :: Point -> LevelId -> State+            -> [((ActorId, Actor), [(ItemId, Item)])] posToActors pos lid s =   let as = actorAssocs (const True) lid s-      apos = filter (\(_, b) -> bpos b == pos) as-  in fmap fst apos+      aps = filter (\(_, b) -> bpos b == pos) as+      f iid = (iid, getItemBody iid s)+      g (aid, b) = ((aid, b), map f $ EM.keys $ bbag b)+      l = map g aps+  in assert (length l <= 1 || all (bproj . snd . fst) l+             `blame` "many actors at the same position" `twith` l)+     l  nearbyFreePoints :: Kind.Ops TileKind                  -> (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State@@ -74,7 +90,7 @@   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)+               && Tile.isWalkable cotile (lvl `at` p)                && unoccupied as p       ps = nub $ start : concatMap (vicinity lxsize lysize) ps   in filter good ps@@ -88,9 +104,9 @@ calculateTotal body s =   let bs = actorList (== bfid body) (blid body) s       bag = EM.unionsWith (+) $ map bbag $ if null bs then [body] else bs-      heroItem = map (\(iid, k) -> (getItemBody iid s, k))-                 $ EM.assocs bag-  in (bag, sum $ map itemPrice heroItem)+      items = map (\(iid, k) -> (getItemBody iid s, k))+              $ EM.assocs bag+  in (bag, sum $ map itemPrice items)  -- | Price an item, taking count into consideration. itemPrice :: (Item, Int) -> Int@@ -127,17 +143,16 @@ whereTo :: LevelId  -- ^ level of the stairs         -> Point    -- ^ position of the stairs         -> Int      -- ^ jump up this many levels-        -> State    -- ^ game state+        -> Dungeon  -- ^ current game dungeon         -> (LevelId, Point)                     -- ^ target level and the position of its receiving stairs-whereTo lid pos k s = assert (k /= 0) $-  let dungeon = sdungeon s-      lvl = dungeon EM.! lid+whereTo lid pos k dungeon = assert (k /= 0) $+  let 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+  in case ascendInBranch dungeon k lid of     [] | isNothing mindex -> (lid, pos)  -- spell fizzles     [] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos, k)     ln : _ -> let lvlTgt = dungeon EM.! ln@@ -170,6 +185,16 @@     Just (l, _) -> CActor aid l     Nothing -> assert `failure` "item not in inventory" `twith` (aid, binv, iid) +actorContainerB :: ActorId -> Actor -> ItemId -> Item -> Maybe Container+actorContainerB aid body iid item =+  case find ((== iid) . snd) $ EM.assocs (binv body) of+    Just (l, _) -> Just $ CActor aid l+    Nothing ->+      let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing+      in case assignLetter iid l body of+        Just l2 -> Just $ CActor aid l2+        Nothing -> Nothing+ getActorInv :: ActorId -> State -> ItemInv getActorInv aid s = binv $ getActorBody aid s @@ -179,6 +204,11 @@ getActorItem aid s =   let f iid = (iid, getItemBody iid s)   in map f $ EM.keys $ getActorBag aid s++getFloorItem :: LevelId -> Point -> State -> [(ItemId, Item)]+getFloorItem lid pos s =+  let f iid = (iid, getItemBody iid s)+  in map f $ EM.keys $ sdungeon s EM.! lid `atI` pos  getItemBody :: ItemId -> State -> Item getItemBody iid s =
Game/LambdaHack/Common/Animation.hs view
@@ -1,52 +1,82 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Screen frames and animations. module Game.LambdaHack.Common.Animation-  ( Attr(..), defAttr, AttrChar(..)-  , SingleFrame(..), emptySingleFrame, xsizeSingleFrame, ysizeSingleFrame+  ( SingleFrame(..), decodeLine, encodeLine+  , overlayOverlay, xsizeSingleFrame, ysizeSingleFrame   , Animation, Frames, renderAnim, restrictAnim   , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout   , AcFrame(..)   , DebugModeCli(..), defDebugModeCli   ) where -import Control.Arrow ((***))+import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import Data.Bits import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.List as L+import Data.Int (Int32)+import Data.List import Data.Maybe import Data.Monoid-import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U+import GHC.Generics (Generic)  import Game.LambdaHack.Common.Color+import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Random +type ScreenLine = U.Vector Int32++decodeLine :: ScreenLine -> [AttrChar]+decodeLine v = map (toEnum . fromIntegral) $ G.toList v++encodeLine :: [AttrChar] -> ScreenLine+encodeLine l = G.fromList $ map (fromIntegral . fromEnum) l+ -- | 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-  , sfBottom :: Text          -- ^ an extra line to show at the bottom+  { sfLevel  :: ![ScreenLine]  -- ^ screen, from top to bottom, line by line+  , sfTop    :: !Overlay       -- ^ some extra lines to show over the top+  , sfBottom :: ![ScreenLine]  -- ^ some extra lines to show at the bottom+  , sfBlank  :: !Bool          -- ^ display only @sfTop@, on blank screen   }   deriving (Eq, Show) -instance Binary SingleFrame where-  put SingleFrame{..} = do-    put sfLevel-    put sfTop-    put sfBottom-  get = do-    sfLevel <- get-    sfTop <- get-    sfBottom <- get-    return SingleFrame{..}+-- | Overlays the @sfTop@ and @sfBottom@ fields onto the @sfLevel@ field.+-- The resulting frame has empty @sfTop@ and @sfBottom@.+-- To be used by simple frontends that don't display overlays+-- in separate windows/panes/scrolled views.+overlayOverlay :: SingleFrame -> SingleFrame+overlayOverlay sf@SingleFrame{..} =+  let lxsize = xsizeSingleFrame sf+      lysize = ysizeSingleFrame sf+      emptyLine = encodeLine+                  $ replicate lxsize (Color.AttrChar Color.defAttr ' ')+      canvasLength = if sfBlank then lysize + 3 else lysize + 1+      canvas | sfBlank = replicate canvasLength emptyLine+             | otherwise = emptyLine : sfLevel+      topTrunc = map (truncateMsg lxsize) $ overlay sfTop+      topLayer = if length topTrunc <= canvasLength+                 then topTrunc+                 else take (canvasLength - 1) topTrunc+                      ++ ["--a portion of the text trimmed--"]+      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      f layerLine canvasLine = encodeLine+        $ addAttr layerLine+          ++ drop (T.length layerLine) (decodeLine canvasLine)+      picture = zipWith f topLayer canvas+      bottomLines = if sfBlank then [] else sfBottom+      newLevel = picture ++ drop (length picture) canvas ++ bottomLines+  in SingleFrame { sfLevel = newLevel+                 , sfTop = emptyOverlay+                 , sfBottom = []+                 , sfBlank }  -- | Animation is a list of frame modifications to play one by one, -- where each modification if a map from positions to level map symbols.@@ -56,12 +86,9 @@ -- | Sequences of screen frames, including delays. type Frames = [Maybe SingleFrame] -emptySingleFrame :: SingleFrame-emptySingleFrame = SingleFrame{sfLevel = [], sfTop = "", sfBottom = ""}- xsizeSingleFrame :: SingleFrame -> X xsizeSingleFrame SingleFrame{sfLevel=[]} = 0-xsizeSingleFrame SingleFrame{sfLevel=line : _} = length line+xsizeSingleFrame SingleFrame{sfLevel=line : _} = G.length line  ysizeSingleFrame :: SingleFrame -> X ysizeSingleFrame SingleFrame{sfLevel} = length sfLevel@@ -69,17 +96,21 @@ -- | Render animations on top of a screen frame. renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames renderAnim lxsize lysize basicFrame (Animation anim) =-  let modifyFrame SingleFrame{sfLevel = levelOld, ..} am =+  let modifyFrame SingleFrame{sfLevel = []} _ =+        assert `failure` (lxsize, lysize, basicFrame, anim)+      modifyFrame SingleFrame{sfLevel = levelOld, ..} am =         let fLine y lineOld =               let f l (x, acOld) =-                    let pos = toPoint lxsize (PointXY (x, y))+                    let pos = Point x y                         !ac = fromMaybe acOld $ EM.lookup pos am                     in ac : l-              in L.foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))-            sfLevel =  -- Fully evaluated.+              in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))+            sfLevel =  -- fully evaluated inside               let f l (y, lineOld) = let !line = fLine y lineOld in line : l-              in L.foldl' f [] (zip [lysize-1,lysize-2..0] (reverse levelOld))-        in Just SingleFrame{..}+              in map encodeLine+                 $ foldl' f [] (zip [lysize-1,lysize-2..0]+                                $ reverse $ map decodeLine levelOld)+        in Just SingleFrame{..}  -- a thunk within Just   in map (modifyFrame basicFrame) anim  blank :: Maybe AttrChar@@ -186,17 +217,17 @@         in EM.findWithDefault ' ' k edge       rollFrame n = do         r <- random-        let l = [ ( PointXY (if topRight then x else xbound - x, y)-                  , fadeChar r n x y )+        let l = [ ( Point (if topRight then x else xbound - x) y+                  , AttrChar defAttr $ fadeChar r n x y )                 | x <- [0..xbound]                 , y <- [max 0 (ybound - (n - x) `div` 2)..ybound]                     ++ [0..min ybound ((n - xbound + x) `div` 2)]                 ]-        return $ EM.fromList $ map (toPoint lxsize *** AttrChar defAttr) l+        return $! EM.fromList l       startN = if out then 3 else 1       fs = [startN..3 * lxsize `divUp` 4 + 2]   as <- mapM rollFrame $ if out then fs else reverse fs-  return $ Animation as+  return $! Animation as  data AcFrame =     AcConfirm !SingleFrame@@ -205,20 +236,6 @@   | AcDelay   deriving (Show, Eq) -instance Binary AcFrame where-  put (AcConfirm fr) = putWord8 0 >> put fr-  put (AcRunning fr) = putWord8 1 >> put fr-  put (AcNormal fr)  = putWord8 2 >> put fr-  put AcDelay        = putWord8 3-  get = do-    tag <- getWord8-    case tag of-      0 -> liftM AcConfirm get-      1 -> liftM AcRunning get-      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.@@ -237,14 +254,18 @@       -- ^ Don't show any animations.   , snewGameCli    :: !Bool       -- ^ Start a new game, overwriting the save file.+  , sdifficultyCli :: !Int+      -- ^ The difficulty level for all UI clients.   , ssavePrefixCli :: !(Maybe String)       -- ^ Prefix of the save game file.   , sfrontendStd   :: !Bool       -- ^ Whether to use the stdout/stdin frontend.+  , sfrontendNo    :: !Bool+      -- ^ Whether to use no frontend at all (for benchmarking, etc.).   , sdbgMsgCli     :: !Bool       -- ^ Show clients' internal debug messages.   }-  deriving (Show, Eq)+  deriving (Show, Eq, Generic)  defDebugModeCli :: DebugModeCli defDebugModeCli = DebugModeCli@@ -254,30 +275,38 @@   , snoMore = False   , snoAnim = Nothing   , snewGameCli = False+  , sdifficultyCli = 0   , ssavePrefixCli = Nothing   , sfrontendStd = False+  , sfrontendNo = 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+instance Binary AcFrame where+  put (AcConfirm fr) = putWord8 0 >> put fr+  put (AcRunning fr) = putWord8 1 >> put fr+  put (AcNormal fr)  = putWord8 2 >> put fr+  put AcDelay        = putWord8 3   get = do-    sfont <- get-    smaxFps <- get-    snoDelay <- get-    snoMore <- get-    snoAnim <- get-    snewGameCli <- get-    ssavePrefixCli <- get-    sfrontendStd <- get-    sdbgMsgCli <- get-    return DebugModeCli{..}+    tag <- getWord8+    case tag of+      0 -> liftM AcConfirm get+      1 -> liftM AcRunning get+      2 -> liftM AcNormal get+      3 -> return AcDelay+      _ -> fail "no parse (AcFrame)"++instance Binary SingleFrame where+  put SingleFrame{..} = do+    put sfLevel+    put sfTop+    put sfBottom+    put sfBlank+  get = do+    sfLevel <- get+    sfTop <- get+    sfBottom <- get+    sfBlank <- get+    return $! SingleFrame{..}++instance Binary DebugModeCli
Game/LambdaHack/Common/AtomicCmd.hs view
@@ -59,14 +59,14 @@   | LoseItemA !ItemId !Item !Int !Container   -- Move actors and items.   | MoveActorA !ActorId !Point !Point-  | WaitActorA !ActorId !Time !Time+  | WaitActorA !ActorId !Bool !Bool   | 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])+  | TrajectoryActorA !ActorId !(Maybe [Vector]) !(Maybe [Vector])   | ColorActorA !ActorId !Color.Color !Color.Color   -- Change faction attributes.   | QuitFactionA !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status)@@ -85,7 +85,7 @@   | AgeGameA !Time   | DiscoverA !LevelId !Point !ItemId !(Kind.Id ItemKind)   | CoverA !LevelId !Point !ItemId !(Kind.Id ItemKind)-  | PerceptionA !LevelId !PerActor !PerActor+  | PerceptionA !LevelId !Perception !Perception   | RestartA !FactionId !Discovery !FactionPers !State !DebugModeCli !Text   | RestartServerA !State   | ResumeA !FactionId !FactionPers@@ -138,7 +138,7 @@   AgeActorA aid t -> Just $ AgeActorA aid (timeNegate t)   HealActorA aid n -> Just $ HealActorA aid (-n)   HasteActorA aid delta -> Just $ HasteActorA aid (speedNegate delta)-  PathActorA aid fromPath toPath -> Just $ PathActorA aid toPath fromPath+  TrajectoryActorA aid fromT toT -> Just $ TrajectoryActorA aid toT fromT   ColorActorA aid fromCol toCol -> Just $ ColorActorA aid toCol fromCol   QuitFactionA fid mb fromSt toSt -> Just $ QuitFactionA fid mb toSt fromSt   LeadFactionA fid source target -> Just $ LeadFactionA fid target source
Game/LambdaHack/Common/AtomicPos.hs view
@@ -7,6 +7,7 @@   , seenAtomicCli, seenAtomicSer   ) where +import Control.Exception.Assert.Sugar import qualified Data.EnumSet as ES  import Game.LambdaHack.Common.Action@@ -18,7 +19,6 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point-import Control.Exception.Assert.Sugar  -- All functions here that take an atomic action are executed -- in the state just before the action is executed.@@ -55,65 +55,61 @@ -- contradict state) if the visibility is lower. posCmdAtomic :: MonadActionRO m => CmdAtomic -> m PosAtomic posCmdAtomic cmd = case cmd of-  CreateActorA _ body _ ->-    return $ PosFidAndSight (bfid body) (blid body) [bpos body]-  DestroyActorA _ body _ ->-    return $ PosFidAndSight (bfid body) (blid body) [bpos body]+  CreateActorA _ body _ -> posProjBody body+  DestroyActorA _ body _ -> posProjBody body   CreateItemA _ _ _ c -> singleContainer c   DestroyItemA _ _ _ c -> singleContainer c-  SpotActorA _ body _ ->-    return $ PosFidAndSight (bfid body) (blid body) [bpos body]-  LoseActorA _ body _ ->-    return $ PosFidAndSight (bfid body) (blid body) [bpos body]+  SpotActorA _ body _ -> posProjBody body+  LoseActorA _ body _ -> posProjBody body   SpotItemA _ _ _ c -> singleContainer c   LoseItemA _ _ _ c -> singleContainer c   MoveActorA aid fromP toP -> do     (lid, _) <- posOfAid aid-    return $ PosSight lid [fromP, toP]+    return $! PosSight lid [fromP, toP]   WaitActorA aid _ _ -> singleAid aid   DisplaceActorA source target -> do     (slid, sp) <- posOfAid source     (tlid, tp) <- posOfAid target-    return $ assert (slid == tlid) $ PosSight slid [sp, tp]+    return $! assert (slid == tlid) $ PosSight slid [sp, tp]   MoveItemA _ _ c1 c2 -> do  -- works even if moved between positions     (lid1, p1) <- posOfContainer c1     (lid2, p2) <- posOfContainer c2-    return $ assert (lid1 == lid2) $ PosSight lid1 [p1, p2]+    return $! assert (lid1 == lid2) $ PosSight lid1 [p1, p2]   AgeActorA aid _ -> singleAid aid   HealActorA aid _ -> singleAid aid   HasteActorA aid _ -> singleAid aid-  PathActorA aid _ _ -> singleAid aid+  TrajectoryActorA aid _ _ -> singleAid aid   ColorActorA aid _ _ -> singleAid aid   QuitFactionA{} -> return PosAll-  LeadFactionA fid _ _ -> return $ PosFidAndSer fid+  LeadFactionA fid _ _ -> return $! PosFidAndSer fid   DiplFactionA{} -> return PosAll-  AlterTileA lid p _ _ -> return $ PosSight lid [p]+  AlterTileA lid p _ _ -> return $! PosSight lid [p]   SearchTileA aid p _ _ -> do     (lid, pos) <- posOfAid aid-    return $ PosSight lid [pos, p]+    return $! PosSight lid [pos, p]   SpotTileA lid ts -> do     let ps = map fst ts-    return $ PosSight lid ps+    return $! PosSight lid ps   LoseTileA lid ts -> do     let ps = map fst ts-    return $ PosSight lid ps-  AlterSmellA lid p _ _ -> return $ PosSmell lid [p]+    return $! PosSight lid ps+  AlterSmellA lid p _ _ -> return $! PosSmell lid [p]   SpotSmellA lid sms -> do     let ps = map fst sms-    return $ PosSmell lid ps+    return $! PosSmell lid ps   LoseSmellA lid sms -> do     let ps = map fst sms-    return $ PosSmell lid ps-  AgeLevelA lid _ ->  return $ PosSight lid []+    return $! PosSmell lid ps+  AgeLevelA lid _ ->  return $! PosSight lid []   AgeGameA _ ->  return PosAll-  DiscoverA lid p _ _ -> return $ PosSight lid [p]-  CoverA lid p _ _ -> return $ PosSight lid [p]+  DiscoverA lid p _ _ -> return $! PosSight lid [p]+  CoverA lid p _ _ -> return $! PosSight lid [p]   PerceptionA{} -> return PosNone-  RestartA fid _ _ _ _ _ -> return $ PosFid fid+  RestartA fid _ _ _ _ _ -> return $! PosFid fid   RestartServerA _ -> return PosSer-  ResumeA fid _ -> return $ PosFid fid+  ResumeA fid _ -> return $! PosFid fid   ResumeServerA _ -> return PosSer-  KillExitA fid -> return $ PosFid fid+  KillExitA fid -> return $! PosFid fid   SaveBkpA -> return PosAll   MsgAllA{} -> return PosAll @@ -122,44 +118,50 @@   StrikeD source target _ _ -> do     (slid, sp) <- posOfAid source     (tlid, tp) <- posOfAid target-    return $ assert (slid == tlid) $ PosSight slid [sp, tp]+    return $! assert (slid == tlid) $ PosSight slid [sp, tp]   RecoilD source target _ _ -> do     (slid, sp) <- posOfAid source     (tlid, tp) <- posOfAid target-    return $ assert (slid == tlid) $ PosSight slid [sp, tp]+    return $! assert (slid == tlid) $ PosSight slid [sp, tp]   ProjectD aid _ -> singleAid aid   CatchD aid _ -> singleAid aid   ActivateD aid _ -> singleAid aid   CheckD aid _ -> singleAid aid   TriggerD aid p _ -> do     (lid, pa) <- posOfAid aid-    return $ PosSight lid [pa, p]+    return $! PosSight lid [pa, p]   ShunD aid p _ -> do     (lid, pa) <- posOfAid aid-    return $ PosSight lid [pa, p]+    return $! PosSight lid [pa, p]   EffectD aid _ -> singleAid aid-  MsgFidD fid _ -> return $ PosFid fid+  MsgFidD fid _ -> return $! PosFid fid   MsgAllD _ -> return PosAll-  DisplayPushD fid -> return $ PosFid fid-  DisplayDelayD fid -> return $ PosFid fid-  RecordHistoryD fid -> return $ PosFid fid+  DisplayPushD fid -> return $! PosFid fid+  DisplayDelayD fid -> return $! PosFid fid+  RecordHistoryD fid -> return $! PosFid fid +posProjBody :: Monad m => Actor -> m PosAtomic+posProjBody body = return $!+  if bproj body+  then PosSight (blid body) [bpos body]+  else PosFidAndSight (bfid body) (blid body) [bpos body]+ singleAid :: MonadActionRO m => ActorId -> m PosAtomic singleAid aid = do   b <- getsState $ getActorBody aid-  return $ PosFidAndSight (bfid b) (blid b) [bpos b]+  return $! PosSight (blid b) [bpos b]  singleContainer :: MonadActionRO m => Container -> m PosAtomic singleContainer c = do   (lid, p) <- posOfContainer c-  return $ PosSight lid [p]+  return $! PosSight lid [p]  -- Determines is a command resets FOV. @Nothing@ means it always does. -- A list of faction means it does for each of the factions. -- This is only an optimization to save perception and spot/lose computation. -- -- Invariant: if @resetsFovAtomic@ determines a faction does not need--- to reset Fov, perception (@perActor@ to be precise, @psmell@ is irrelevant)+-- to reset Fov, perception (@ptotal@ to be precise, @psmell@ is irrelevant) -- of that faction does not change upon recomputation. Otherwise, -- save/restore would change game state. resetsFovAtomic :: MonadActionRO m => CmdAtomic -> m (Maybe [FactionId])@@ -227,10 +229,10 @@ seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool seenAtomicCli knowEvents fid per posAtomic =   case posAtomic of-    PosSight _ ps -> knowEvents || all (`ES.member` totalVisible per) ps+    PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents     PosFidAndSight fid2 _ ps ->-      knowEvents || fid == fid2 || all (`ES.member` totalVisible per) ps-    PosSmell _ ps -> knowEvents || all (`ES.member` smellVisible per) ps+      fid == fid2 || all (`ES.member` totalVisible per) ps || knowEvents+    PosSmell _ ps -> all (`ES.member` smellVisible per) ps || knowEvents     PosFid fid2 -> fid == fid2     PosFidAndSer fid2 -> fid == fid2     PosSer -> False
Game/LambdaHack/Common/AtomicSem.hs view
@@ -7,11 +7,11 @@   ) where  import Control.Arrow (second)+import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.List -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState@@ -23,6 +23,7 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time@@ -46,7 +47,7 @@   AgeActorA aid t -> ageActorA aid t   HealActorA aid n -> healActorA aid n   HasteActorA aid delta -> hasteActorA aid delta-  PathActorA aid fromPath toPath -> pathActorA aid fromPath toPath+  TrajectoryActorA aid fromT toT -> trajectoryActorA aid fromT toT   ColorActorA aid fromCol toCol -> colorActorA aid fromCol toCol   QuitFactionA fid mbody fromSt toSt -> quitFactionA fid mbody fromSt toSt   LeadFactionA fid source target -> leadFactionA fid source target@@ -64,8 +65,8 @@   AgeGameA t -> ageGameA t   DiscoverA{} -> return ()  -- Server keeps all atomic comands so the semantics   CoverA{} -> return ()     -- of inverses has to be reasonably inverse.-  PerceptionA _ outPA inPA ->-    assert (not (EM.null outPA && EM.null inPA)) $ return ()+  PerceptionA _ outPer inPer ->+    assert (not (nullPer outPer && nullPer inPer)) skip   RestartA fid sdisco sfper s _ _ -> restartA fid sdisco sfper s   RestartServerA s -> restartServerA s   ResumeA{} -> return ()@@ -80,7 +81,8 @@ createActorA aid body ais = do   -- Add actor to @sactorD@.   let f Nothing = Just body-      f (Just b) = assert `failure` "actor already added" `twith` (aid, body, b)+      f (Just b) = assert `failure` "actor already added"+                          `twith` (aid, body, b)   modifyState $ updateActorD $ EM.alter f aid   -- Add actor to @sprio@.   let g Nothing = Just [aid]@@ -203,7 +205,7 @@   modifyState $ updateActorBody aid               $ \body -> body {bpos = toP, boldpos = fromP} -waitActorA :: MonadAction m => ActorId -> Time -> Time -> m ()+waitActorA :: MonadAction m => ActorId -> Bool -> Bool -> m () waitActorA aid fromWait toWait = assert (fromWait /= toWait) $ do   b <- getsState $ getActorBody aid   assert (fromWait == bwait b `blame` "unexpected waited actor time"@@ -245,11 +247,7 @@   body <- getsState $ getActorBody aid   ais <- getsState $ getActorItem aid   destroyActorA aid body 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-                     }+  let newBody = body {btime = timeAdd (btime body) t}   createActorA aid newBody ais  healActorA :: MonadAction m => ActorId -> Int -> m ()@@ -260,17 +258,18 @@ hasteActorA aid delta = assert (delta /= speedZero) $ do   modifyState $ updateActorBody aid $ \ b ->     let newSpeed = speedAdd (bspeed b) delta-    in assert (newSpeed >= speedZero `blame` "actor slowed below zero"-                                     `twith` (aid, delta, bspeed b, newSpeed)) $-       b {bspeed = newSpeed}+    in assert (newSpeed >= speedZero+               `blame` "actor slowed below zero"+               `twith` (aid, delta, b, newSpeed))+       $ b {bspeed = newSpeed} -pathActorA :: MonadAction m+trajectoryActorA :: MonadAction m            => ActorId -> Maybe [Vector] -> Maybe [Vector] -> m ()-pathActorA aid fromPath toPath = assert (fromPath /= toPath) $ do+trajectoryActorA aid fromT toT = assert (fromT /= toT) $ do   body <- getsState $ getActorBody aid-  assert (fromPath == bpath body `blame` "unexpected actor path"-                                 `twith` (aid, fromPath, toPath, body)) skip-  modifyState $ updateActorBody aid $ \b -> b {bpath = toPath}+  assert (fromT == btrajectory body `blame` "unexpected actor trajectory"+                                    `twith` (aid, fromT, toT, body)) skip+  modifyState $ updateActorBody aid $ \b -> b {btrajectory = toT}  colorActorA :: MonadAction m             => ActorId -> Color.Color -> Color.Color -> m ()@@ -319,7 +318,10 @@     modifyState $ updateFaction $ EM.adjust (adj fid1) fid2  -- | Alter an attribute (actually, the only, the defining attribute)--- of a visible tile. This is similar to e.g., @PathActorA@.+-- of a visible tile. This is similar to e.g., @TrajectoryActorA@.+-- We do not modify @lclear@ here, because we can't keep track of+-- alterations to unknown tiles. The server would need to send @lclear@+-- updates for each invisible tile alteration that affects it. alterTileA :: MonadAction m            => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind            -> m ()@@ -332,18 +334,18 @@   -- and it suddenly changes into another tile,   -- which at the same time becomes visible (e.g., an open door).   -- See 'AtomicSemCli' for how this is reported to the client.-  let adj ts = assert (ts Kind.! p == fromTile-                       || ts Kind.! p == freshClientTile+  let adj ts = assert (ts PointArray.! p == fromTile+                       || ts PointArray.! p == freshClientTile                        `blame` "unexpected altered tile kind"-                       `twith` (lid, p, fromTile, toTile, ts Kind.! p))-               $ ts Kind.// [(p, toTile)]+                       `twith` (lid, p, fromTile, toTile, ts PointArray.! p))+               $ ts PointArray.// [(p, toTile)]   updateLevel lid $ updateTile adj   case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of     (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@,+-- Notice previously invisible tiles. This is similar to @SpotActorA@, -- but done in bulk, because it often involves dozens of tiles pers move. -- We don't check that the tiles at the positions in question are unknown -- to save computation, especially for clients that remember tiles@@ -353,17 +355,17 @@ spotTileA lid ts = assert (not $ null ts) $ do   Kind.COps{cotile} <- getsState scops   Level{ltile} <- getLevel lid-  let adj tileMap = tileMap Kind.// ts+  let adj tileMap = tileMap PointArray.// ts   updateLevel lid $ updateTile adj   let f (p, t2) = do-        let t1 = ltile Kind.! p+        let t1 = ltile PointArray.! 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 visible tiles. Unlike @spotTileA@, it verifies+-- Stop noticing 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@@ -371,9 +373,9 @@   let unknownId = ouniqGroup "unknown space"       matches _ [] = True       matches tileMap ((p, ov) : rest) =-        tileMap Kind.! p == ov && matches tileMap rest+        tileMap PointArray.! p == ov && matches tileMap rest       tu = map (second (const unknownId)) ts-      adj tileMap = assert (matches tileMap ts) $ tileMap Kind.// tu+      adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu   updateLevel lid $ updateTile adj   let f (_, t1) =         when (Tile.isExplorable cotile t1) $@@ -382,21 +384,16 @@  alterSmellA :: MonadAction m             => 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` "unexpected tile smell"-  --                                   `twith` (lid, p, fromSm, toSm, sm)) toSm-  let alt _ =  toSm+alterSmellA lid p fromSm toSm = do+  let alt sm = assert (sm == fromSm `blame` "unexpected tile smell"+                                    `twith` (lid, p, fromSm, toSm, sm)) toSm   updateLevel lid $ updateSmell $ EM.alter alt p  spotSmellA :: MonadAction m => LevelId -> [(Point, Time)] -> m () spotSmellA lid sms = assert (not $ null sms) $ do   let alt sm Nothing = Just sm-      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` "smell already added"---                                   `twith` (lid, sms, sm, oldSm)+      alt sm (Just oldSm) = assert `failure` "smell already added"+                                   `twith` (lid, sms, sm, oldSm)       f (p, sm) = EM.alter (alt sm) p       upd m = foldr f m sms   updateLevel lid $ updateSmell upd
Game/LambdaHack/Common/ClientCmd.hs view
@@ -47,7 +47,7 @@   CmdAtomicAI cmdA@SpotTileA{} -> debugPlain cmd cmdA   CmdAtomicAI cmdA -> debugPretty cmd cmdA   CmdQueryAI aid -> debugAid aid "CmdQueryAI" cmd-  CmdPingAI -> return $ showT cmd+  CmdPingAI -> return $! tshow cmd  debugCmdClientUI :: MonadActionRO m => CmdClientUI -> m Text debugCmdClientUI cmd = case cmd of@@ -57,19 +57,19 @@   CmdAtomicUI cmdA -> debugPretty cmd cmdA   SfxAtomicUI sfx -> do     ps <- posSfxAtomic sfx-    return $ showT (cmd, ps)+    return $! tshow (cmd, ps)   CmdQueryUI aid -> debugAid aid "CmdQueryUI" cmd-  CmdPingUI -> return $ showT cmd+  CmdPingUI -> return $! tshow cmd  debugPretty :: (MonadActionRO m, Show a) => a -> CmdAtomic -> m Text debugPretty cmd cmdA = do   ps <- posCmdAtomic cmdA-  return $ showT (cmd, ps)+  return $! tshow (cmd, ps)  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+  return $! T.pack $ show (cmd, ps)  -- too large for pretty show  data DebugAid a = DebugAid   { label   :: !Text@@ -88,12 +88,12 @@   else do     b <- getsState $ getActorBody aid     time <- getsState $ getLocalTime (blid b)-    return $ showT DebugAid { label-                            , cmd-                            , lid = blid b-                            , time-                            , aid-                            , faction = bfid b }+    return $! tshow DebugAid { label+                             , cmd+                             , lid = blid b+                             , time+                             , aid+                             , faction = bfid b }  -- | Connection channels between the server and a single client. data ChanServer c d = ChanServer@@ -104,7 +104,7 @@ -- | Connections to the human-controlled client of a faction and -- to the AI client for the same faction. type ConnServerFaction = ( Maybe (ChanFrontend, ChanServer CmdClientUI CmdSer)-                         , ChanServer CmdClientAI CmdSerTakeTime )+                         , ChanServer CmdClientAI CmdTakeTimeSer )  -- | Connection information for all factions, indexed by faction identifier. type ConnServerDict = EM.EnumMap FactionId ConnServerFaction
Game/LambdaHack/Common/Color.hs view
@@ -9,6 +9,7 @@   ) where  import Data.Binary+import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import qualified Data.Hashable as Hashable import GHC.Generics (Generic) @@ -39,10 +40,6 @@  instance Hashable.Hashable Color -instance Binary Color where-  put = putWord8 . toEnum . fromEnum-  get = fmap (toEnum . fromEnum) getWord8- -- | The default colours, to optimize attribute setting. defBG, defFG :: Color defBG = Black@@ -55,14 +52,10 @@   }   deriving (Show, Eq, Ord) -instance Binary Attr where-  put Attr{..} = do-    put fg-    put bg-  get = do-    fg <- get-    bg <- get-    return Attr{..}+instance Enum Attr where+  fromEnum Attr{..} = fromEnum fg + unsafeShiftL (fromEnum bg) 8+  toEnum n = Attr (toEnum $ n .&. (2 ^ (8 :: Int)  - 1))+                  (toEnum $ unsafeShiftR n 8)  -- | The default attribute, to optimize attribute setting. defAttr :: Attr@@ -72,16 +65,12 @@   { acAttr :: !Attr   , acChar :: !Char   }-  deriving (Show, Eq)+  deriving (Show, Eq, Ord) -instance Binary AttrChar where-  put AttrChar{..} = do-    put acAttr-    put acChar-  get = do-    acAttr <- get-    acChar <- get-    return AttrChar{..}+instance Enum AttrChar where+  fromEnum AttrChar{..} = fromEnum acAttr + unsafeShiftL (fromEnum acChar) 16+  toEnum n = AttrChar (toEnum $ n .&. (2 ^ (16 :: Int) - 1))+                      (toEnum $ unsafeShiftR n 16)  -- | A helper for the terminal frontends that display bright via bold. isBright :: Color -> Bool@@ -136,3 +125,25 @@ _olorToRGB BrMagenta = "#FF55FF" _olorToRGB BrCyan    = "#55FFFF" _olorToRGB BrWhite   = "#FFFFFF"++instance Binary Color where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8++instance Binary Attr where+  put Attr{..} = do+    put fg+    put bg+  get = do+    fg <- get+    bg <- get+    return $! Attr{..}++instance Binary AttrChar where+  put AttrChar{..} = do+    put acAttr+    put acChar+  get = do+    acAttr <- get+    acChar <- get+    return $! AttrChar{..}
− Game/LambdaHack/Common/ConfigIO.hs 
@@ -1,97 +0,0 @@--- | Personal game configuration file support.-module Game.LambdaHack.Common.ConfigIO-  ( CP, appDataDir, mkConfig, get, getOption, set, getItems, to_string, dump-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.Char as Char-import qualified Data.ConfigFile as CF-import System.Directory-import System.Environment-import System.FilePath--import Game.LambdaHack.Server.Config--overrideCP :: CP -> FilePath -> IO CP-overrideCP cp@(CP defCF) cfile = do-  cpExists <- doesFileExist cfile-  if not cpExists-    then return cp-    else do-      c <- CF.readfile defCF cfile-      return $ toCP $ assert `forceEither` c---- | 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 TH.--- The player configuration comes from file @cfile@.-mkConfig :: String -> FilePath -> IO CP-mkConfig configDefault cfile = do-  let delComment = map (drop 2) $ lines configDefault-      unConfig = unlines delComment-      -- Evaluate, to catch config errors ASAP.-      !defCF = assert `forceEither` CF.readstring CF.emptyCP unConfig-      !defCP = toCP defCF-  overrideCP defCP cfile---- | Personal data directory for the game. Depends on the OS and the game,--- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.-appDataDir :: IO FilePath-appDataDir = do-  progName <- getProgName-  let name = takeWhile Char.isAlphaNum progName-  getAppUserDataDirectory name---- | Dumps the current configuration to a file.-dump :: Config -> FilePath -> IO ()-dump Config{configSelfString} fn = do-  current <- getCurrentDirectory-  let path = current </> fn-  writeFile path configSelfString---- | Simplified setting of an option in a given section. Overwriting forbidden.-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" `twith` (s, o)-  else CP $ assert `forceEither` CF.set conf s o v---- | The content of the configuration file. It's parsed--- in a case sensitive way (unlike by default in ConfigFile).-newtype CP = CP CF.ConfigParser--instance Show CP where-  show (CP conf) = show $ CF.to_string conf---- | Switches all names to case sensitive (unlike by default in--- the "ConfigFile" library) and wraps in the constructor.-toCP :: CF.ConfigParser -> CP-toCP cf = CP $ cf {CF.optionxform = id}---- | 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.-getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a-getOption (CP conf) s o =-  if CF.has_option conf s o-  then Just $ assert `forceEither` CF.get conf s o-  else Nothing---- | 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 assert `forceEither` CF.get conf s o-  else assert `failure` "unknown CF option" `twith` (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 assert `forceEither` CF.items conf s-  else assert `failure` "unknown CF section" `twith` (s, CF.to_string conf)--to_string :: CP -> String-to_string (CP conf) = CF.to_string conf
Game/LambdaHack/Common/Effect.hs view
@@ -5,6 +5,7 @@   ( Effect(..), effectTrav, effectToSuffix   ) where +import Control.Exception.Assert.Sugar import qualified Control.Monad.State as St import Data.Binary import qualified Data.Hashable as Hashable@@ -13,7 +14,6 @@  import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random-import Control.Exception.Assert.Sugar  -- TODO: document each constructor -- Effects of items, tiles, etc. The type argument represents power.@@ -22,7 +22,7 @@     NoEffect   | Heal !Int   | Hurt !RollDice !a-  | Mindprobe !Int    -- the @Int@ is a hack to send the result to clients+  | Mindprobe Int    -- the @Int@ is a lazy hack to send the result to clients   | Dominate   | CallFriend !Int   | Summon !Int@@ -31,7 +31,7 @@   | Regeneration !a   | Searching !a   | Ascend !Int-  | Escape+  | Escape !Int   deriving (Show, Read, Eq, Ord, Generic, Functor)  instance Hashable.Hashable a => Hashable.Hashable (Effect a)@@ -42,24 +42,24 @@ -- | Transform an effect using a stateful function. effectTrav :: Effect a -> (a -> St.State s b) -> St.State s (Effect b) effectTrav NoEffect _ = return NoEffect-effectTrav (Heal p) _ = return $ Heal p+effectTrav (Heal p) _ = return $! Heal p effectTrav (Hurt dice a) f = do   b <- f a-  return $ Hurt dice b-effectTrav (Mindprobe x) _ = return $ Mindprobe x+  return $! Hurt dice b+effectTrav (Mindprobe x) _ = return $! Mindprobe x effectTrav Dominate _ = return Dominate-effectTrav (CallFriend p) _ = return $ CallFriend p-effectTrav (Summon p) _ = return $ Summon p-effectTrav (CreateItem p) _ = return $ CreateItem p+effectTrav (CallFriend p) _ = return $! CallFriend p+effectTrav (Summon p) _ = return $! Summon p+effectTrav (CreateItem p) _ = return $! CreateItem p effectTrav ApplyPerfume _ = return ApplyPerfume effectTrav (Regeneration a) f = do   b <- f a-  return $ Regeneration b+  return $! Regeneration b effectTrav (Searching a) f = do   b <- f a-  return $ Searching b-effectTrav (Ascend p) _ = return $ Ascend p-effectTrav Escape _ = return Escape+  return $! Searching b+effectTrav (Ascend p) _ = return $! Ascend p+effectTrav (Escape p) _ = return $! Escape p  -- | Suffix to append to a basic content name if the content causes the effect. effectToSuff :: Show a => Effect a -> (a -> Text) -> Text@@ -69,7 +69,7 @@     Heal p | p > 0 -> "of healing" <> affixBonus p     Heal 0 -> "of bloodletting"     Heal p -> "of wounding" <> affixBonus p-    Hurt dice t -> "(" <> showT dice <> ")" <> t+    Hurt dice t -> "(" <> tshow dice <> ")" <> t     Mindprobe{} -> "of soul searching"     Dominate -> "of domination"     CallFriend p -> "of aid calling" <> affixPower p@@ -81,7 +81,7 @@     Ascend p | p > 0 -> "of ascending" <> affixPower p     Ascend p | p < 0 -> "of descending" <> affixPower (- p)     Ascend{} -> assert `failure` effect-    Escape -> "of escaping"+    Escape{} -> "of escaping"  effectToSuffix :: Effect Int -> Text effectToSuffix effect = effectToSuff effect affixBonus@@ -90,10 +90,10 @@ affixPower p = case compare p 1 of   EQ -> ""   LT -> assert `failure` "power less than 1" `twith` p-  GT -> " (+" <> showT p <> ")"+  GT -> " (+" <> tshow p <> ")"  affixBonus :: Int -> Text affixBonus p = case compare p 0 of   EQ -> ""-  LT -> " (" <> showT p <> ")"-  GT -> " (+" <> showT p <> ")"+  LT -> " (" <> tshow p <> ")"+  GT -> " (+" <> tshow p <> ")"
Game/LambdaHack/Common/Faction.hs view
@@ -2,7 +2,7 @@ -- the hero faction battling the monster and the animal factions. module Game.LambdaHack.Common.Faction   ( FactionId, FactionDict, Faction(..), Diplomacy(..), Outcome(..), Status(..)-  , isSpawnFact, isSummonFact, isAtWar, isAllied+  , isHeroFact, isHorrorFact, isSpawnFact, isSummonFact, isAtWar, isAllied   ) where  import Data.Binary@@ -58,12 +58,22 @@   }   deriving (Show, Eq, Ord) --- | Tell whether the faction can spawn actors.-isSpawnFact :: Kind.COps -> Faction -> Bool-isSpawnFact Kind.COps{cofaction=Kind.Ops{okind}} fact =+-- | Tell whether the faction consists of heroes.+isHeroFact :: Kind.COps -> Faction -> Bool+isHeroFact Kind.COps{cofaction=Kind.Ops{okind}} fact =   let kind = okind (gkind fact)-  in maybe False (> 0) $ lookup "spawn" $ ffreq kind+  in maybe False (> 0) $ lookup "hero" $ ffreq kind +-- | Tell whether the faction consists of summoned horrors only.+isHorrorFact :: Kind.COps -> Faction -> Bool+isHorrorFact Kind.COps{cofaction=Kind.Ops{okind}} fact =+  let kind = okind (gkind fact)+  in maybe False (> 0) $ lookup "horror" $ ffreq kind++-- | Tell whether the faction can spawn actors.+isSpawnFact :: Faction -> Bool+isSpawnFact fact = playerSpawn (gplayer fact) > 0+ -- | Tell whether actors of the faction can be summoned by items, etc. isSummonFact :: Kind.COps -> Faction -> Bool isSummonFact Kind.COps{cofaction=Kind.Ops{okind}} fact =@@ -95,7 +105,7 @@     gdipl <- get     gquit <- get     gleader <- get-    return Faction{..}+    return $! Faction{..}  instance Binary Diplomacy where   put Unknown  = putWord8 0@@ -138,4 +148,4 @@     stOutcome <- get     stDepth <- get     stInfo <- get-    return Status{..}+    return $! Status{..}
Game/LambdaHack/Common/Feature.hs view
@@ -10,27 +10,25 @@  import Game.LambdaHack.Common.Effect --- | All possible terrain tile features, some of them parameterized--- or dependent on outside coefficients, e.g., on the tile secrecy value.+-- | All possible terrain tile features. data Feature =     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+  | OpenTo !Text         -- ^ goes from a closed to an open tile when altered+  | CloseTo !Text        -- ^ goes from an open to a closed 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-  | Lit                  -- ^ is lit with an ambient shine+  | Dark                 -- ^ is not lit with an ambient shine   | Suspect              -- ^ may not be what it seems (clients only)   | Aura !(Effect Int)   -- ^ sustains the effect continuously, TODO   | Impenetrable         -- ^ can never be excavated nor seen through    | CanItem              -- ^ items can be generated there   | CanActor             -- ^ actors and stairs can be generated there-  | Exit                 -- ^ is a (not hidden) door, stair, etc.-  | Path                 -- ^ used for visible paths throughout the level+  | Trail                -- ^ used for visible trails throughout the level   deriving (Show, Read, Eq, Ord, Generic)  instance Binary Feature
Game/LambdaHack/Common/Flavour.hs view
@@ -13,7 +13,6 @@  import Data.Binary import qualified Data.Hashable as Hashable-import qualified Data.List as L import Data.Text (Text) import GHC.Generics (Generic) @@ -33,8 +32,8 @@  -- | Turn a colour set into a flavour set. zipPlain, zipFancy :: [Color] -> [Flavour]-zipPlain = L.map (Flavour False)-zipFancy = L.map (Flavour True)+zipPlain = map (Flavour False)+zipFancy = map (Flavour True)  -- | The standard full set of flavours. stdFlav :: [Flavour]
Game/LambdaHack/Common/HighScore.hs view
@@ -1,11 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore-  ( ScoreTable, empty, register, slideshow+  ( ScoreTable, empty, register, highSlideshow   ) where  import Data.Binary-import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU@@ -20,36 +19,39 @@ -- | A single score record. Records are ordered in the highscore table, -- from the best to the worst, in lexicographic ordering wrt the fields below. data ScoreRecord = ScoreRecord-  { points  :: !Int        -- ^ the score-  , negTime :: !Time       -- ^ game time spent (negated, so less better)-  , date    :: !ClockTime  -- ^ date of the last game interruption-  , status  :: !Status     -- ^ reason of the game interruption+  { points     :: !Int        -- ^ the score+  , negTime    :: !Time       -- ^ game time spent (negated, so less better)+  , date       :: !ClockTime  -- ^ date of the last game interruption+  , status     :: !Status     -- ^ reason of the game interruption+  , difficulty :: !Int        -- ^ difficulty of the game   }   deriving (Eq, Ord) +-- TODO: move all to Text -- | Show a single high score, from the given ranking in the high score table. showScore :: (Int, ScoreRecord) -> [Text] showScore (pos, score) =   let Status{stOutcome, stDepth} = status score       died = case stOutcome of-        Killed -> "perished on level " ++ show (abs stDepth) ++ ","-        Defeated -> "was defeated"-        Camping -> "is camping somewhere,"-        Conquer -> "eliminated all opposition"-        Escape -> "emerged victorious"-        Restart -> "resigned prematurely"+        Killed   -> "Perished on level " ++ show (abs stDepth)+        Defeated -> "Was defeated"+        Camping  -> "Camps somewhere"+        Conquer  -> "Slew all opposition"+        Escape   -> "Emerged victorious"+        Restart  -> "Resigned prematurely"       curDate = calendarTimeToString . toUTCTime . date $ score-      big, lil :: String-      big = "                                                 "-      lil = "              "       turns = - (negTime score `timeFit` timeTurn)+      diff = 5 - difficulty score+      diffText :: String+      diffText | diff == 5 = ""+               | otherwise = printf " (difficulty %d)" diff      -- TODO: the spaces at the end are hand-crafted. Remove when display      -- of overlays adds such spaces automatically.   in map T.pack-       [ big-       , printf "%4d. %6d  This adventuring party %s after %d turns  "-                pos (points score) died turns-       , lil ++ printf "on %s.  " curDate+       [ ""+       , printf "%4d. %6d  %s%s"+                pos (points score) died diffText+       , "              " ++ printf "after %d turns on %s." turns curDate        ]  -- | The list of scores, in decreasing order.@@ -67,8 +69,8 @@ -- Make sure the table doesn't grow too large. insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int) insertPos s (ScoreTable table) =-  let (prefix, suffix) = L.span (> s) table-      pos = L.length prefix + 1+  let (prefix, suffix) = span (> s) table+      pos = length prefix + 1   in (ScoreTable $ prefix ++ [s] ++ take (100 - pos) suffix, pos)  -- | Register a new score in a score table.@@ -77,42 +79,45 @@          -> Time        -- ^ game time spent          -> Status      -- ^ reason of the game interruption          -> ClockTime   -- ^ current date+         -> Int         -- ^ difficulty level          -> Maybe (ScoreTable, Int)-register table total time status@Status{stOutcome} date =-  let points = if stOutcome `elem` [Killed, Defeated, Restart]-               then (total + 1) `div` 2-               else if stOutcome == Conquer-                    then let turnsSpent = timeFit time timeTurn-                             speedup = 10000 - 5 * turnsSpent-                             bonus = sqrt $ fromIntegral speedup :: Double-                         in 10 + floor bonus-                    else total+register table total time status@Status{stOutcome} date difficulty =+  let pUnscaled = if stOutcome `elem` [Killed, Defeated, Restart]+                  then (total + 1) `div` 2+                  else if stOutcome == Conquer+                       then let turnsSpent = timeFit time timeTurn+                                speedup = 10000 - 5 * turnsSpent+                                bonus = sqrt $ fromIntegral speedup :: Double+                            in 10 + floor bonus+                       else total+      points = (round :: Double -> Int)+               $ fromIntegral pUnscaled * 1.5 ^^ difficulty       negTime = timeNegate time       score = ScoreRecord{..}   in if points > 0 then Just $ insertPos score table else Nothing  -- | Show a screenful of the high scores table. -- Parameter height is the number of (3-line) scores to be shown.-showTable :: ScoreTable -> Int -> Int -> Overlay-showTable (ScoreTable table) start height =+tshowable :: ScoreTable -> Int -> Int -> [Text]+tshowable (ScoreTable table) start height =   let zipped    = zip [1..] table       screenful = take height . drop (start - 1) $ zipped   in concatMap showScore screenful ++ [moreMsg]  -- | Produce a couple of renderings of the high scores table.-showCloseScores :: Int -> ScoreTable -> Int -> [Overlay]+showCloseScores :: Int -> ScoreTable -> Int -> [[Text]] showCloseScores pos h height =   if pos <= height-  then [showTable h 1 height]-  else [showTable h 1 height,-        showTable h (max (height + 1) (pos - height `div` 2)) height]+  then [tshowable h 1 height]+  else [tshowable h 1 height,+        tshowable h (max (height + 1) (pos - height `div` 2)) height]  -- | Generate a slideshow with the current and previous scores.-slideshow :: ScoreTable -- ^ current score table-          -> Int        -- ^ position of the current high score in the table-          -> Status     -- ^ reason of the game interruption-          -> Slideshow-slideshow table pos status =+highSlideshow :: ScoreTable -- ^ current score table+              -> Int        -- ^ position of the current score in the table+              -> Status     -- ^ reason of the game interruption+              -> Slideshow+highSlideshow table pos status =   let (_, nlines) = normalLevelBound  -- TODO: query terminal size instead       height = nlines `div` 3       (subject, person, msgUnless) =@@ -141,19 +146,21 @@         [ MU.SubjectVerb person MU.Yes subject "award you"         , MU.Ordinal pos, "place"         , msgUnless ]-  in toSlideshow $ map ([msg] ++) $ showCloseScores pos table height+  in toSlideshow True $ map ([msg] ++) $ showCloseScores pos table height  instance Binary ScoreRecord where-  put (ScoreRecord p n (TOD cs cp) s) = do+  put (ScoreRecord p n (TOD cs cp) s difficulty) = do     put p     put n     put cs     put cp     put s+    put difficulty   get = do     p <- get     n <- get     cs <- get     cp <- get     s <- get-    return (ScoreRecord p n (TOD cs cp) s)+    difficulty <- get+    return $! ScoreRecord p n (TOD cs cp) s difficulty
+ Game/LambdaHack/Common/HumanCmd.hs view
@@ -0,0 +1,158 @@+-- | Abstract syntax human player commands.+module Game.LambdaHack.Common.HumanCmd+  ( CmdCategory(..), HumanCmd(..), Trigger(..)+  , noRemoteHumanCmd, categoryDescription, cmdDescription+  ) where++import Control.Exception.Assert.Sugar+import Data.Text (Text)+import qualified NLP.Miniutter.English as MU++import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Vector++data CmdCategory = CmdMenu | CmdMove | CmdItem | CmdTgt | CmdMeta | CmdDebug+  deriving (Show, Read, Eq)++categoryDescription :: CmdCategory -> Text+categoryDescription CmdMenu = "Main Menu"+categoryDescription CmdMove = "Movement and terrain alteration"+categoryDescription CmdItem = "Inventory and items"+categoryDescription CmdTgt = "Targeting"+categoryDescription CmdMeta = "Assorted"+categoryDescription CmdDebug = "Debug"++-- | Abstract syntax of player commands.+data HumanCmd =+    -- These usually take time.+    Move !Vector+  | Run !Vector+  | Wait+  | Pickup+  | Drop+  | Project     ![Trigger]+  | Apply       ![Trigger]+  | AlterDir    ![Trigger]+  | TriggerTile ![Trigger]+  | StepToTarget+  | Resend+    -- Below this line, commands do not take time.+  | GameRestart !Text+  | GameExit+  | GameSave+  | GameDifficultyCycle+    -- Below this line, commands do not notify the server.+  | PickLeader !Int+  | MemberCycle+  | MemberBack+  | Inventory+  | SelectActor+  | SelectNone+  | Clear+  | Repeat !Int+  | Record+  | History+  | MarkVision+  | MarkSmell+  | MarkSuspect+  | Help+  | MainMenu+  | Macro !Text ![String]+    -- These are mostly related to targeting.+  | MoveCursor !Vector !Int+  | TgtFloor+  | TgtEnemy+  | TgtUnknown+  | TgtItem+  | TgtStair !Bool+  | TgtAscend !Int+  | EpsIncr !Bool+  | TgtClear+  | Cancel+  | Accept+  deriving (Eq, Ord, Show, Read)++data Trigger =+    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)++-- | Commands that are forbidden on a remote level, because they+-- would usually take time when invoked on one.+-- Note that some commands that take time are not included,+-- because they don't take time in targeting mode.+noRemoteHumanCmd :: HumanCmd -> Bool+noRemoteHumanCmd cmd = case cmd of+  Wait          -> True+  Pickup        -> True+  Drop          -> True+  Project{}     -> True+  Apply{}       -> True+  AlterDir{}    -> True+  StepToTarget  -> True+  Resend        -> True+  _             -> False++-- | Description of player commands.+cmdDescription :: HumanCmd -> Text+cmdDescription cmd = case cmd of+  Move v      -> "move" <+> compassText v+  Run v       -> "run" <+> compassText v+  Wait        -> "wait"+  Pickup      -> "get an object"+  Drop        -> "drop an object"+  Project ts  -> triggerDescription ts+  Apply ts    -> triggerDescription ts+  AlterDir ts -> triggerDescription ts+  TriggerTile ts -> triggerDescription ts+  StepToTarget -> "make one step towards the target"+  Resend      -> "resend last server command"++  GameRestart t -> "new" <+> t <+> "game"+  GameExit    -> "save and exit"+  GameSave    -> "save game"++  GameDifficultyCycle -> "cycle difficulty of the next game"+  PickLeader{} -> "pick leader"+  MemberCycle -> "cycle among party members on the level"+  MemberBack  -> "cycle among party members in the dungeon"+  Inventory   -> "display inventory"+  SelectActor -> "select (or deselect) a party member"+  SelectNone  -> "deselect (or select) all on the level"+  Clear       -> "clear messages"+  Repeat 1    -> "play back last keys"+  Repeat n    -> "play back last keys" <+> tshow n <+> "times"+  Record      -> "start recording a macro"+  History     -> "display player diary"+  MarkVision  -> "mark visible area"+  MarkSmell   -> "mark smell"+  MarkSuspect -> "mark suspect terrain"+  Help        -> "display help"+  MainMenu    -> "display the Main Menu"+  Macro t _   -> t++  MoveCursor v 1 -> "move cursor" <+> compassText v+  MoveCursor v k ->+    "move cursor up to" <+> tshow k <+> "steps" <+> compassText v+  TgtFloor    -> "cycle targeting mode"+  TgtEnemy    -> "target enemy"+  TgtUnknown  -> "target the closest unknown spot"+  TgtItem     -> "target the closest item"+  TgtStair up -> "target the closest stairs" <+> if up then "up" else "down"+  TgtAscend k | k == 1  -> "target next shallower level"+  TgtAscend k | k >= 2  -> "target" <+> tshow k    <+> "levels shallower"+  TgtAscend k | k == -1 -> "target next deeper level"+  TgtAscend k | k <= -2 -> "target" <+> tshow (-k) <+> "levels deeper"+  TgtAscend _ -> assert `failure` "void level change when targeting"+                        `twith` cmd+  EpsIncr True  -> "swerve targeting line"+  EpsIncr False -> "unswerve targeting line"+  TgtClear    -> "clear target/cursor"+  Cancel      -> "cancel action"+  Accept      -> "accept choice"++triggerDescription :: [Trigger] -> Text+triggerDescription [] = "trigger a thing"+triggerDescription (t : _) = makePhrase [verb t, object t]
Game/LambdaHack/Common/Item.hs view
@@ -6,7 +6,7 @@ -- inventory manangement and items proper. module Game.LambdaHack.Common.Item   ( -- * Teh @Item@ type-    ItemId, Item(..), jkind, buildItem, newItem, viewItem+    ItemId, Item(..), jkind, buildItem, newItem     -- * Inventory search   , strongestSearch, strongestSword, strongestRegen    -- * The item discovery types@@ -15,8 +15,11 @@   , FlavourMap, emptyFlavourMap, dungeonFlavourMap     -- * Textual description   , partItem, partItemWs, partItemAW+    -- * Assorted+  , isFragile, isExplosive, isLingering, causeIEffects   ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import qualified Data.EnumMap.Strict as EM@@ -29,15 +32,14 @@ import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Flavour+import qualified Game.LambdaHack.Common.ItemFeature as IF import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind-import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency  -- | A unique identifier of an item in the dungeon.@@ -67,6 +69,7 @@   , jname    :: !Text        -- ^ individual generic name   , jflavour :: !Flavour     -- ^ individual flavour   , jeffect  :: !(Effect Int)  -- ^ the effect when activated+  , jweight  :: !Int         -- ^ weight in grams, obvious enough   }   deriving (Show, Eq, Ord, Generic) @@ -106,20 +109,21 @@         case iflavour kind of           [fl] -> fl           _ -> flavour EM.! ikChosen+      jweight = iweight kind   in Item{..}  -- | Generate an item based on level. newItem :: Kind.Ops ItemKind -> FlavourMap -> DiscoRev         -> Frequency Text -> Int -> Int         -> Rnd (Item, Int, ItemKind)-newItem cops@Kind.Ops{opick, okind} flavour discoRev itemFreq lvl depth = do+newItem coitem@Kind.Ops{opick, okind} flavour discoRev itemFreq lvl depth = do   itemGroup <- frequency itemFreq   let castItem :: Int -> Rnd (Item, Int, ItemKind)       castItem 0 | nullFreq itemFreq = assert `failure` "no fallback items"                                               `twith` (itemFreq, lvl, depth)       castItem 0 = do         let newFreq = setFreq itemFreq itemGroup 0-        newItem cops flavour discoRev newFreq lvl depth+        newItem coitem flavour discoRev newFreq lvl depth       castItem count = do         ikChosen <- fmap (fromMaybe $ assert `failure` itemGroup)                     $ opick itemGroup (const True)@@ -128,16 +132,15 @@         if jcount == 0 then           castItem $ count - 1         else do-          effect <- effectTrav (ieffect kind) (castDeep lvl depth)+          let kindEffect = case causeIEffects coitem ikChosen of+                [] -> NoEffect+                eff : _TODO -> eff+          effect <- effectTrav kindEffect (castDeep lvl depth)           return ( buildItem flavour discoRev ikChosen kind effect                  , jcount                  , kind )   castItem 10 --- | Represent an item on the map.-viewItem :: Item -> (Char, Color.Color)-viewItem i = (jsymbol i, flavourToColor $ jflavour i)- -- | Flavours assigned by the server to item kinds, in this particular game. newtype FlavourMap = FlavourMap (EM.EnumMap (Kind.Id ItemKind) Flavour)   deriving (Show, Binary)@@ -193,6 +196,40 @@ strongestRegen is =   strongestItem is $ \ i ->     case jeffect i of Regeneration k -> Just k; _ -> Nothing++isFragile :: Kind.Ops ItemKind -> Discovery -> Item -> Bool+isFragile Kind.Ops{okind} disco i =+  case jkind disco i of+    Nothing -> False+    Just ik ->+      let getTo IF.Fragile _acc = True+          getTo IF.Explode{} _acc = True+          getTo _ acc = acc+      in foldr getTo False $ ifeature $ okind ik++isExplosive :: Kind.Ops ItemKind -> Discovery -> Item -> Maybe Text+isExplosive Kind.Ops{okind} disco i =+  case jkind disco i of+    Nothing -> Nothing+    Just ik ->+      let getTo (IF.Explode cgroup) _acc = Just cgroup+          getTo _ acc = acc+      in foldr getTo Nothing $ ifeature $ okind ik++isLingering :: Kind.Ops ItemKind -> Discovery -> Item -> Int+isLingering Kind.Ops{okind} disco i =+  case jkind disco i of+    Nothing -> 100+    Just ik ->+      let getTo (IF.Linger percent) _acc = percent+          getTo _ acc = acc+      in foldr getTo 100 $ ifeature $ okind ik++causeIEffects :: Kind.Ops ItemKind -> Kind.Id ItemKind -> [Effect RollDeep]+causeIEffects Kind.Ops{okind} ik = do+  let getTo (IF.Cause eff) acc = eff : acc+      getTo _ acc = acc+  foldr getTo [] $ ifeature $ okind ik  -- | The part of speech describing the item. partItem :: Kind.Ops ItemKind -> Discovery -> Item -> (MU.Part, MU.Part)
+ Game/LambdaHack/Common/ItemFeature.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Item features.+module Game.LambdaHack.Common.ItemFeature+  ( Feature(..)+  ) where++import Data.Binary+import Data.Text (Text)+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Random++-- | All possible item features.+data Feature =+    Cause !(Effect RollDeep)  -- ^ causes the effect when triggered+  | ChangeTo !Text            -- ^ changes to this item kind group when altered+  | Explode !Text             -- ^ explode, producing this group of shrapnel+  | Fragile                   -- ^ breaks even when not hitting an enemy+  | Linger !Int               -- ^ fly for this percentage of 2 turns+  deriving (Show, Eq, Ord, Generic)++instance Binary Feature
Game/LambdaHack/Common/Key.hs view
@@ -1,20 +1,20 @@+{-# LANGUAGE DeriveGeneric #-} -- | Frontend-independent keyboard input operations. module Game.LambdaHack.Common.Key   ( Key(..), handleDir, dirAllMoveKey-  , moveBinding, keyTranslate, Modifier(..), KM(..), showKM, escKey+  , moveBinding, mkKM, keyTranslate, Modifier(..), KM(..), showKM, escKey   ) where +import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.Char as Char-import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T+import GHC.Generics (Generic) import Prelude hiding (Left, Right)  import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Common.VectorXY  -- TODO: if the file grows much larger, split it and move a part to Utils/ @@ -25,6 +25,7 @@   | Space   | Tab   | BackTab+  | BackSpace   | PgUp   | PgDn   | Left@@ -37,78 +38,25 @@   | 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)+  deriving (Read, Ord, Eq, Generic) -instance Binary Key where-  put Esc         = putWord8 0-  put Return      = putWord8 1-  put Space       = putWord8 2-  put Tab         = putWord8 3-  put BackTab     = putWord8 4-  put PgUp        = putWord8 5-  put PgDn        = putWord8 6-  put Left        = putWord8 7-  put Right       = putWord8 8-  put Up          = putWord8 9-  put Down        = putWord8 10-  put End         = putWord8 11-  put Begin       = putWord8 12-  put Home        = putWord8 13-  put (KP c)      = putWord8 14 >> put c-  put (Char c)    = putWord8 15 >> put c-  put (Unknown s) = putWord8 16 >> put s-  get = do-    tag <- getWord8-    case tag of-      0  -> return Esc-      1  -> return Return-      2  -> return Space-      3  -> return Tab-      4  -> return BackTab-      5  -> return PgUp-      6  -> return PgDn-      7  -> return Left-      8  -> return Right-      9  -> return Up-      10 -> return Down-      11 -> return End-      12 -> return Begin-      13 -> return Home-      14 -> fmap KP get-      15 -> fmap Char get-      16 -> fmap Unknown get-      _ -> fail "no parse (Key)"+instance Binary Key  -- | Our own encoding of modifiers. Incomplete. data Modifier =     NoModifier   | Control-  deriving (Ord, Eq)+  deriving (Read, Ord, Eq, Generic) -instance Binary Modifier where-  put NoModifier = putWord8 0-  put Control    = putWord8 1-  get = do-    tag <- getWord8-    case tag of-      0  -> return NoModifier-      1  -> return Control-      _ -> fail "no parse (Modifier)"+instance Binary Modifier  data KM = KM {modifier :: !Modifier, key :: !Key}-  deriving (Ord, Eq)+  deriving (Read, Ord, Eq, Generic)  instance Show KM where   show = T.unpack . showKM -instance Binary KM where-  put KM {..} = do-    put key-    put modifier-  get = do-    key <- get-    modifier <- get-    return KM {..}+instance Binary KM  -- Common and terse names for keys. showKey :: Key -> Text@@ -118,15 +66,16 @@ showKey Space    = "SPACE" showKey Tab      = "TAB" showKey BackTab  = "SHIFT-TAB"-showKey PgUp     = "PGUP"-showKey PgDn     = "PGDOWN"-showKey Left     = "LEFT"-showKey Right    = "RIGHT"+showKey BackSpace = "BACKSPACE" showKey Up       = "UP" showKey Down     = "DOWN"+showKey Left     = "LEFT"+showKey Right    = "RIGHT"+showKey Home     = "HOME" showKey End      = "END"+showKey PgUp     = "PGUP"+showKey PgDn     = "PGDOWN" showKey Begin    = "BEGIN"-showKey Home     = "HOME" showKey (KP c)   = "KEYPAD(" <> T.singleton c <> ")" showKey (Unknown s) = s @@ -167,29 +116,38 @@  -- | Configurable event handler for the direction keys. -- Used for directed commands such as close door.-handleDir :: X -> KM -> (Vector -> a) -> a -> a-handleDir lxsize KM{modifier=NoModifier, key} h k =-  let mvs = moves lxsize-      assocs = zip dirAllMoveKey $ mvs ++ mvs-  in maybe k h (L.lookup key assocs)-handleDir _lxsize _ _h k = k+handleDir :: KM -> (Vector -> a) -> a -> a+handleDir KM{modifier=NoModifier, key} h k =+  let assocs = zip dirAllMoveKey $ moves ++ moves+  in maybe k h (lookup key assocs)+handleDir _ _ k = k  -- TODO: deduplicate -- | Binding of both sets of movement keys.-moveBinding :: (VectorXY -> a) -> (VectorXY -> a)+moveBinding :: (Vector -> a) -> (Vector -> a)             -> [(KM, a)] moveBinding move run =   let assign f (km, dir) = (km, f dir)       rNoModifier = repeat NoModifier       rControl = repeat Control-  in map (assign move) (zip (zipWith KM rNoModifier dirViMoveKey) movesXY) ++-     map (assign move) (zip (zipWith KM rNoModifier dirMoveKey) movesXY) ++-     map (assign run)  (zip (zipWith KM rNoModifier dirViRunKey) movesXY) ++-     map (assign run)  (zip (zipWith KM rNoModifier dirRunKey) movesXY) ++-     map (assign run)  (zip (zipWith KM rControl dirMoveKey) movesXY) ++-     map (assign run)  (zip (zipWith KM rControl dirRunKey) movesXY) ++-     map (assign run)  (zip (zipWith KM rControl dirHeroKey ) movesXY)+  in map (assign move) (zip (zipWith KM rNoModifier dirViMoveKey) moves) +++     map (assign move) (zip (zipWith KM rNoModifier dirMoveKey) moves) +++     map (assign run)  (zip (zipWith KM rNoModifier dirViRunKey) moves) +++     map (assign run)  (zip (zipWith KM rNoModifier dirRunKey) moves) +++     map (assign run)  (zip (zipWith KM rControl dirMoveKey) moves) +++     map (assign run)  (zip (zipWith KM rControl dirRunKey) moves) +++     map (assign run)  (zip (zipWith KM rControl dirHeroKey ) moves) +mkKM :: String -> KM+mkKM s = let mkKey sk =+               case keyTranslate sk of+                 Unknown _ ->+                   assert `failure` "unknown key" `twith` s+                 key -> key+         in case s of+           ('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control}+           _ -> KM {key=mkKey s, modifier=NoModifier}+ -- | Translate key from a GTK string description to our internal key type. -- To be used, in particular, for the command bindings and macros -- in the config file.@@ -198,6 +156,7 @@ keyTranslate "greater"       = Char '>' keyTranslate "period"        = Char '.' keyTranslate "colon"         = Char ':'+keyTranslate "semicolon"     = Char ';' keyTranslate "comma"         = Char ',' keyTranslate "question"      = Char '?' keyTranslate "dollar"        = Char '$'@@ -205,20 +164,24 @@ keyTranslate "KP_Multiply"   = Char '*' keyTranslate "slash"         = Char '/' keyTranslate "KP_Divide"     = Char '/'+keyTranslate "backslash"     = Char '\\' keyTranslate "underscore"    = Char '_' keyTranslate "minus"         = Char '-' keyTranslate "KP_Subtract"   = Char '-' keyTranslate "plus"          = Char '+' keyTranslate "KP_Add"        = Char '+'+keyTranslate "equal"         = Char '=' keyTranslate "bracketleft"   = Char '[' keyTranslate "bracketright"  = Char ']' keyTranslate "braceleft"     = Char '{' keyTranslate "braceright"    = Char '}'+keyTranslate "apostrophe"    = Char '\'' keyTranslate "Escape"        = Esc keyTranslate "Return"        = Return keyTranslate "space"         = Space keyTranslate "Tab"           = Tab keyTranslate "ISO_Left_Tab"  = BackTab+keyTranslate "BackSpace"     = BackSpace keyTranslate "KP_Up"         = Up keyTranslate "KP_Down"       = Down keyTranslate "KP_Left"       = Left
Game/LambdaHack/Common/Kind.hs view
@@ -1,17 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind-  ( -- * General content types-    Id, sentinelId, Speedup(..), Ops(..), COps(..), createOps, stdRuleset-    -- * Arrays of content identifiers-  , Array, (!), (//), listArray, array, bounds, foldlArray+  ( Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset+  , Tab, createTab, accessTab   ) where +import Control.Exception.Assert.Sugar import qualified Data.Array.Unboxed as A import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.Ix as Ix-import qualified Data.List as L+import Data.List import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.Text (Text)@@ -29,29 +28,37 @@ import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind-import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency  -- | Content identifiers for the content type @c@. newtype Id c = Id Word8-  deriving (Show, Eq, Ord, Ix.Ix, Enum)--instance Binary (Id c) where-  put (Id i) = put i-  get = fmap Id get--sentinelId :: Id c-sentinelId = Id 255+  deriving (Show, Eq, Ord, Ix.Ix, Enum, Bounded, Binary)  -- | Type family for auxiliary data structures for speeding up -- content operations. data family Speedup a  data instance Speedup TileKind = TileSpeedup-  { isClearTab :: Id TileKind -> Bool-  , isLitTab   :: Id TileKind -> Bool+  { isClearTab :: !Tab+  , isLitTab   :: !Tab+  , isWalkableTab :: !Tab+  , isPassableTab :: !Tab+  , isDoorTab :: !Tab+  , isSuspectTab :: !Tab   } +newtype Tab = Tab (A.UArray (Id TileKind) Bool)++createTab :: Ops TileKind -> (TileKind -> Bool) -> Tab+createTab Ops{ofoldrWithKey, obounds} p =+  let f _ k acc = p k : acc+      clearAssocs = ofoldrWithKey f []+  in Tab $ A.listArray obounds clearAssocs++accessTab :: Tab -> Id TileKind -> Bool+{-# INLINE accessTab #-}+accessTab (Tab tab) ki = tab A.! ki+ -- | Content operations for the content of type @a@. data Ops a = Ops   { okind         :: Id a -> a      -- ^ the content element at given id@@ -70,44 +77,44 @@ -- of type @a@. createOps :: forall a. Show a => ContentDef a -> Ops a createOps ContentDef{getName, getFreq, content, validate} =-  assert (Id (fromIntegral $ length content) < sentinelId) $+  assert (length content <= fromEnum (maxBound :: Id a)) $   let kindMap :: EM.EnumMap (Id a) a-      !kindMap = EM.fromDistinctAscList $ L.zip [Id 0..] content+      !kindMap = EM.fromDistinctAscList $ zip [Id 0..] content       kindFreq :: M.Map Text (Frequency (Id a, a))       kindFreq =-        let tuples = [ (group, (n, (i, k)))+        let tuples = [ (cgroup, (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 <> "')"+                     , (cgroup, n) <- getFreq k, n > 0 ]+            f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m+            lists = foldl' f M.empty tuples+            nameFreq cgroup = toFreq $ "opick ('" <> cgroup <> "')"         in M.mapWithKey nameFreq lists       okind i = fromMaybe (assert `failure` "no kind" `twith` (i, kindMap))                 $ EM.lookup i kindMap-      correct a = not (T.null (getName a)) && L.all ((> 0) . snd) (getFreq a)+      correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a)       offenders = validate content   in assert (allB correct content) $-     assert (L.null offenders `blame` "content not valid" `twith` offenders)+     assert (null offenders `blame` "content not valid" `twith` offenders)      -- By this point 'content' can be GCd.      Ops        { okind-       , ouniqGroup = \group ->+       , ouniqGroup = \cgroup ->            let freq = fromMaybe (assert `failure` "no unique group"-                                        `twith` (group, kindFreq))-                      $ M.lookup group kindFreq+                                        `twith` (cgroup, kindFreq))+                      $ M.lookup cgroup kindFreq            in case runFrequency freq of              [(n, (i, _))] | n > 0 -> i-             l -> assert `failure` "not unique" `twith` (l, group, kindFreq)-       , opick = \group p ->-           case M.lookup group kindFreq of+             l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq)+       , opick = \cgroup p ->+           case M.lookup cgroup kindFreq of              Just freq | not $ nullFreq freq -> fmap Just $ frequency $ do                (i, k) <- freq                breturn (p k) i                {- with MonadComprehensions:-               frequency [ i | (i, k) <- kindFreq M.! group, p k ]+               frequency [ i | (i, k) <- kindFreq M.! cgroup, p k ]                -}              _ -> return Nothing-       , ofoldrWithKey = \f z -> L.foldr (\(i, a) -> f i a) z+       , ofoldrWithKey = \f z -> foldr (\(i, a) -> f i a) z                                  $ EM.assocs kindMap        , obounds = ( fst $ EM.findMin kindMap                    , fst $ EM.findMax kindMap )@@ -135,46 +142,3 @@  instance Eq COps where   (==) _ _ = True---- | Arrays of content identifiers pointing to the content type @c@,--- where the identifiers are represented as @Word8@--- (and so content of type @c@ can have at most 256 elements).--- The arrays are indexed by type @i@, e.g., a dungeon tile position.-newtype Array i c = Array (A.UArray i Word8)-  deriving Eq---- TODO: save/restore is still too slow, but we are already past--- the point of diminishing returns. A dramatic change would be--- low-level conversion to ByteString and serializing that.-instance (Ix.Ix i, Binary i) => Binary (Array i c) where-  put (Array a) = put a-  get = fmap Array get--instance (Ix.Ix i, Show i) => Show (Array i c) where-  show a = "Kind.Array with bounds " ++ show (bounds a)---- | Content identifiers array lookup.-(!) :: Ix.Ix i => Array i c -> i -> Id c-(!) (Array a) i = Id $ a A.! i---- | Construct a content identifiers array updated with the association list.-(//) :: Ix.Ix i => Array i c -> [(i, Id c)] -> Array i c-(//) (Array a) l = Array $ a A.// [(i, e) | (i, Id e) <- l]---- | Create a content identifiers array from a list of elements.-listArray :: Ix.Ix i => (i, i) -> [Id c] -> Array i c-listArray bds l = Array $ A.listArray bds [e | Id e <- l]---- | Create a content identifiers array from an association list.-array :: Ix.Ix i => (i, i) -> [(i, Id c)] -> Array i c-array bds l = Array $ A.array bds [(i, e) | (i, Id e) <- l]---- | Content identifiers array bounds.-bounds :: Ix.Ix i => Array i c -> (i, i)-bounds (Array a) = A.bounds a---- | Fold left strictly over an array.-foldlArray :: Ix.Ix i => (a -> Id c -> a) -> a -> Array i c -> a-foldlArray f z0 (Array a) = lgo z0 $ A.elems a- where lgo z []       = z-       lgo z (x : xs) = let fzx = f z (Id x) in fzx `seq` lgo fzx xs
Game/LambdaHack/Common/Level.hs view
@@ -12,14 +12,16 @@     -- * Level update   , updatePrio, updateSmell, updateFloor, updateTile     -- * Level query-  , at, atI, accessible, accessibleDir, isSecretPos, hideTile+  , at, atI, checkAccess, checkDoorAccess, accessible, accessibleDir+  , isSecretPos, hideTile   , findPos, findPosTry, mapLevelActors_, mapDungeonActors_  ) where +import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.Bits as Bits import qualified Data.EnumMap.Strict as EM-import qualified Data.List as L+import Data.Maybe import Data.Text (Text) import GHC.Generics (Generic) @@ -27,7 +29,7 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY+import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Tile import qualified Game.LambdaHack.Common.Tile as Tile@@ -35,15 +37,14 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind-import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency  -- | The complete dungeon is a map from level names to levels. type Dungeon = EM.EnumMap LevelId Level  -- | Levels in the current branch, @k@ levels shallower than the current.-ascendInBranch :: Dungeon -> LevelId -> Int -> [LevelId]-ascendInBranch dungeon lid k =+ascendInBranch :: Dungeon -> Int -> LevelId -> [LevelId]+ascendInBranch dungeon k lid =   -- Currently there is just one branch, so the computation is simple.   let (minD, maxD) =         case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of@@ -69,7 +70,7 @@ type ItemFloor = EM.EnumMap Point ItemBag  -- | Tile kinds on the map.-type TileMap = Kind.Array Point TileKind+type TileMap = PointArray.Array (Kind.Id TileKind)  -- | Current smell on map tiles. type SmellMap = EM.EnumMap Point SmellTime@@ -86,15 +87,17 @@   , lsmell    :: !SmellMap   -- ^ remembered smells on the level   , ldesc     :: !Text       -- ^ level description   , lstair    :: !([Point], [Point])-                            -- ^ destinations of (up, down) stairs+                             -- ^ destinations of (up, down) stairs   , lseen     :: !Int        -- ^ currently remembered clear tiles-  , lclear    :: !Int        -- ^ total number of initially clear tiles+  , lclear    :: !Int        -- ^ total number of initially clear tiles;+                             --   set to 1 on clients when fully explored   , ltime     :: !Time       -- ^ date of the last activity on the level   , litemNum  :: !Int        -- ^ number of initial items, 0 for clients   , litemFreq :: !(Frequency Text)  -- ^ frequency of initial items,                                     --   [] for clients   , lsecret   :: !Int        -- ^ secret tile seed   , lhidden   :: !Int        -- ^ secret tile density+  , lescape   :: !Bool       -- ^ has an Effect.Escape tile   }   deriving (Show, Eq) @@ -121,23 +124,40 @@  -- | Query for tile kinds on the map. at :: Level -> Point -> Kind.Id TileKind-at Level{ltile} p = ltile Kind.! p+at Level{ltile} p = ltile PointArray.! p  -- | Query for items on the ground. atI :: Level -> Point -> ItemBag atI Level{lfloor} p = EM.findWithDefault EM.empty p lfloor +checkAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool)+checkAccess Kind.COps{corule} _ =+  case raccessible $ Kind.stdRuleset corule of+    Nothing -> Nothing+    Just ch -> Just $ \spos tpos -> ch spos tpos++checkDoorAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool)+checkDoorAccess Kind.COps{corule, cotile} lvl =+  case raccessibleDoor $ Kind.stdRuleset corule of+    Nothing -> Nothing+    Just chDoor ->+      Just $ \spos tpos ->+        let st = lvl `at` spos+            tt = lvl `at` tpos+        in not (Tile.isDoor cotile st || Tile.isDoor cotile tt)+           || chDoor spos tpos+ -- | Check whether one position is accessible from another, -- using the formula from the standard ruleset. -- Precondition: the two positions are next to each other. accessible :: Kind.COps -> Level -> Point -> Point -> Bool-accessible Kind.COps{cotile=Kind.Ops{okind=okind}, corule}-           lvl@Level{lxsize} spos tpos =-  assert (chessDist lxsize spos tpos == 1) $-  let check = raccessible $ Kind.stdRuleset corule-      src = okind $ lvl `at` spos-      tgt = okind $ lvl `at` tpos-  in check lxsize spos src tpos tgt+accessible cops@Kind.COps{cotile} lvl =+  let checkWalkability =+        Just $ \_ tpos -> Tile.isWalkable cotile $ lvl `at` tpos+      conditions = catMaybes [ checkWalkability+                             , checkAccess cops lvl+                             , checkDoorAccess cops lvl ]+  in \spos tpos -> all (\f -> f spos tpos) conditions  -- | Check whether actors can move from a position along a unit vector, -- using the formula from the standard ruleset.@@ -158,11 +178,14 @@ -- | Find a random position on the map satisfying a predicate. findPos :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point findPos ltile p =-  let search = do-        pos <- randomR $ Kind.bounds ltile-        let tile = ltile Kind.! pos+  let (x, y) = PointArray.sizeA ltile+      search = do+        px <- randomR (0, x - 1)+        py <- randomR (0, y - 1)+        let pos = Point{..}+            tile = ltile PointArray.! pos         if p pos tile-          then return pos+          then return $! pos           else search   in search @@ -179,12 +202,15 @@            -> Rnd Point findPosTry _        ltile m []         = findPos ltile m findPosTry numTries ltile m l@(_ : tl) = assert (numTries > 0) $-  let search 0 = findPosTry numTries ltile m tl+  let (x, y) = PointArray.sizeA ltile+      search 0 = findPosTry numTries ltile m tl       search k = do-        pos <- randomR $ Kind.bounds ltile-        let tile = ltile Kind.! pos-        if m pos tile && L.all (\p -> p pos tile) l-          then return pos+        px <- randomR (0, x - 1)+        py <- randomR (0, y - 1)+        let pos = Point{..}+            tile = ltile PointArray.! pos+        if m pos tile && all (\p -> p pos tile) l+          then return $! pos           else search (k - 1)   in search numTries @@ -216,6 +242,7 @@     put litemFreq     put lsecret     put lhidden+    put lescape   get = do     ldepth <- get     lprio <- get@@ -233,4 +260,5 @@     litemFreq <- get     lsecret <- get     lhidden <- get-    return Level{..}+    lescape <- get+    return $! Level{..}
Game/LambdaHack/Common/Misc.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Hacks that haven't found their home yet. module Game.LambdaHack.Common.Misc-  ( normalLevelBound, maxLevelDim, divUp, Freqs, breturn+  ( normalLevelBound, divUp, Freqs, breturn   , FactionId, LevelId   ) where @@ -19,15 +19,11 @@  -- | Level bounds. TODO: query terminal size instead and scroll view. normalLevelBound :: (Int, Int)-normalLevelBound = (79, 21)---- | Maximal supported level X and Y dimension (32768). Not checked anywhere.--- The value is chosen to support architectures with 32-bit ints.-maxLevelDim :: Int-maxLevelDim = 2 ^ (15 :: Int)+normalLevelBound = (79, 20) +infixl 7 `divUp` -- | Integer division, rounding up.-divUp :: Int -> Int -> Int+divUp :: Integral a => a -> a -> a divUp n k = (n + k - 1) `div` k  -- | For each group that the kind belongs to, denoted by a @Text@ name
Game/LambdaHack/Common/Msg.hs view
@@ -2,35 +2,39 @@ -- | Game messages displayed on top of the screen for the player to read. module Game.LambdaHack.Common.Msg   ( makePhrase, makeSentence-  , Msg, (<>), (<+>), showT, moreMsg, yesnoMsg, truncateMsg+  , Msg, (<>), (<+>), tshow, toWidth, moreMsg, yesnoMsg, truncateMsg   , Report, emptyReport, nullReport, singletonReport, addMsg   , splitReport, renderReport, findInReport   , History, emptyHistory, singletonHistory, mergeHistory   , addReport, renderHistory, takeHistory-  , Overlay, stringByLocation-  , Slideshow(runSlideshow), splitOverlay, toSlideshow)+  , Overlay(overlay), emptyOverlay, truncateToOverlay, toOverlay+  , Slideshow(slideshow), splitOverlay, toSlideshow)   where  import Data.Binary import qualified Data.ByteString.Char8 as BS-import Data.Char-import qualified Data.EnumMap.Strict as EM import Data.List-import Data.Monoid hiding ((<>))+import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8)-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+import Game.LambdaHack.Common.Point +infixr 6 <+>  -- TODO: not needed when we require a very new minimorph+(<+>) :: Text -> Text -> Text+(<+>) = (MU.<+>)+ -- Pretty print and pack the result of @show@.-showT :: Show a => a -> Text-showT x = T.pack $ Show.Pretty.ppShow x+tshow :: Show a => a -> Text+tshow x = T.pack $ Show.Pretty.ppShow x +toWidth :: Int -> Text -> Text+toWidth n x = T.take n (T.justifyLeft n ' ' x)+ -- | Re-exported English phrase creation functions, applied to default -- irregular word sets. makePhrase, makeSentence :: [MU.Part] -> Text@@ -56,7 +60,7 @@   let xs = case T.lines xsRaw of         [] -> xsRaw         [line] -> line-        line : _ -> line <> T.replicate (w + 1) " "+        line : _ -> T.justifyLeft (w + 1) ' ' line       len = T.length xs   in case compare w len of        LT -> T.snoc (T.take (w - 1) xs) '$'@@ -67,11 +71,7 @@  -- | The type of a set of messages to show at the screen at once. newtype Report = Report [(BS.ByteString, Int)]-  deriving (Show)--instance Binary Report where-  put (Report x) = put x-  get = fmap Report get+  deriving (Show, Binary)  -- | Empty set of messages. emptyReport :: Report@@ -96,11 +96,12 @@  -- | Split a messages into chunks that fit in one line. -- We assume the width of the messages line is the same as of level map.-splitReport :: Report -> [Text]-splitReport r =-  let w = fst normalLevelBound + 1-  in splitText w $ renderReport r+splitReport :: X -> Report -> Overlay+splitReport w r = Overlay $ splitReportList w r +splitReportList :: X -> Report -> [Text]+splitReportList w r = splitText w $ renderReport r+ -- | Render a report as a (possibly very long) string. renderReport :: Report  -> Text renderReport (Report []) = T.empty@@ -109,7 +110,7 @@  renderRepetition :: (BS.ByteString, Int) -> Text renderRepetition (s, 1) = decodeUtf8 s-renderRepetition (s, n) = decodeUtf8 s <> "<x" <> showT n <> ">"+renderRepetition (s, n) = decodeUtf8 s <> "<x" <> tshow n <> ">"  findInReport :: (BS.ByteString -> Bool) -> Report -> Maybe BS.ByteString findInReport f (Report xns) = find f $ map fst xns@@ -118,27 +119,22 @@ -- other than whitespace or punctuation. Space characters are removed -- from the start, but never from the end of lines. Newlines are respected. splitText :: X -> Text -> [Text]-splitText w xs = concatMap (splitText' w . T.dropWhile isSpace) $ T.lines xs+splitText w xs = concatMap (splitText' w . T.stripStart) $ T.lines xs  splitText' :: X -> Text -> [Text] splitText' w xs-  | w <= 0 = [xs]  -- border case, we cannot make progress   | w >= T.length xs = [xs]  -- no problem, everything fits   | otherwise =       let (pre, post) = T.splitAt w xs           (ppre, ppost) = T.break (== ' ') $ T.reverse pre-          testPost = T.dropWhile isSpace ppost+          testPost = T.stripEnd ppost       in if T.null testPost          then pre : splitText w post          else T.reverse ppost : splitText w (T.reverse ppre <> post)  -- | The history of reports. newtype History = History [Report]-  deriving Show--instance Binary History where-  put (History x) = put x-  get = fmap History get+  deriving (Show, Binary)  -- | Empty history of reports. emptyHistory :: History@@ -156,7 +152,9 @@  -- | Render history as many lines of text, wrapping if necessary. renderHistory :: History -> Overlay-renderHistory (History h) = concatMap splitReport h+renderHistory (History h) =+  let w = fst normalLevelBound + 1+  in Overlay $ concatMap (splitReportList w) h  -- | Add a report to history, handling repetitions. addReport :: Report -> History -> History@@ -176,48 +174,47 @@ -- | A series of screen lines that may or may not fit the width nor height -- of the screen. An overlay may be transformed by adding the first line -- and/or by splitting into a slideshow of smaller overlays.-type Overlay = [Text]+newtype Overlay = Overlay {overlay :: [Text]}+  deriving (Show, Eq, Binary) --- | Returns a function that looks up the characters in the--- string by position. Takes the width and height of the display plus--- the string. Returns also the message to print at the top and bottom.-stringByLocation :: X -> Y -> Overlay-                 -> (Text, PointXY -> Maybe Char, Maybe Text)-stringByLocation _ _ [] = (T.empty, const Nothing, Nothing)-stringByLocation lxsize lysize (msgTop : ls) =-  let (over, bottom) = splitAt lysize $ map (truncateMsg lxsize) ls-      m = EM.fromDistinctAscList-          $ zip [0..]-                (map (EM.fromDistinctAscList . zip [0..] . T.unpack) over)-      msgBottom = case bottom of-                  [] -> Nothing-                  [s] -> Just s-                  _ -> Just "--a portion of the text trimmed--"-  in (truncateMsg lxsize msgTop,-      \ (PointXY (x, y)) -> EM.lookup y m >>= \ n -> EM.lookup x n,-      msgBottom)+emptyOverlay :: Overlay+emptyOverlay = Overlay [] +truncateToOverlay :: X -> Text -> Overlay+truncateToOverlay lxsize msg = Overlay [truncateMsg lxsize msg]++toOverlay :: [Text] -> Overlay+toOverlay = Overlay+ -- | Split an overlay into a slideshow in which each overlay, -- 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 =+-- fits on the screen wrt height (but lines may be too wide).+splitOverlay :: Bool -> Y -> Overlay -> Overlay -> Slideshow+splitOverlay onBlank yspace (Overlay msg) (Overlay ls) =   let over = msg ++ ls-  in if length over <= lysize + 2-     then Slideshow [over]  -- all fits on one screen-     else let (pre, post) = splitAt (lysize + 1) over-              Slideshow slides = splitOverlay lysize msg post-          in Slideshow $ (pre ++ [moreMsg]) : slides+  in if length over <= yspace+     then Slideshow (onBlank, [Overlay over])  -- all fits on one screen+     else let (pre, post) = splitAt (yspace - 1) over+              Slideshow (_, slides) =+                splitOverlay onBlank yspace (Overlay msg) (Overlay post)+          in Slideshow $ (onBlank, (Overlay $ pre ++ [moreMsg]) : slides)  -- | A few overlays, displayed one by one upon keypress. -- When displayed, they are trimmed, not wrapped -- and any lines below the lower screen edge are not visible.-newtype Slideshow = Slideshow {runSlideshow :: [Overlay]}-  deriving (Monoid, Show)+-- If the boolean flag is set, the overlay is displayed over a blank screen,+-- including the bottom lines.+newtype Slideshow = Slideshow {slideshow :: (Bool, [Overlay])}+  deriving Show --- | Declare the list of overlays to be fit for display on the screen.+instance Monoid Slideshow where+  mempty = Slideshow (False, [])+  mappend (Slideshow (b1, l1)) (Slideshow (b2, l2)) =+    Slideshow (b1 || b2, l1 ++ l2)++-- | Declare the list of raw overlays to be fit for display on the screen. -- In particular, current @Report@ is eiter empty or unimportant -- or contained in the overlays and if any vertical or horizontal -- trimming of the overlays happens, this is intended.-toSlideshow :: [Overlay] -> Slideshow-toSlideshow = Slideshow+toSlideshow :: Bool -> [[Text]] -> Slideshow+toSlideshow onBlank l = Slideshow (onBlank, map Overlay l)
Game/LambdaHack/Common/Perception.hs view
@@ -17,9 +17,9 @@ -- 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+  ( Perception(Perception), PerceptionVisible(PerceptionVisible)   , totalVisible, smellVisible-  , actorSeesPos, nullPer, addPer, diffPer, smellFromActors+  , nullPer, addPer, diffPer   , FactionPers, Pers   ) where @@ -28,30 +28,20 @@ import qualified Data.EnumSet as ES import GHC.Generics (Generic) -import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ActorKind --- TOOD: if really needed, optimize by representing as a set of intervals. newtype PerceptionVisible = PerceptionVisible-  { pvisible :: ES.EnumSet Point}+    {pvisible :: ES.EnumSet Point}   deriving (Show, Eq, Binary) -type PerActor = EM.EnumMap ActorId PerceptionVisible-+-- TOOD: if really needed, optimize by representing as a set of intervals+-- or a set of bitmaps, like the internal representation of IntSet. -- | The type representing the perception of a faction on a level.--- The total visibility holds the sum of FOVs of all actors--- 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+  { ptotal :: !PerceptionVisible  -- ^ sum over all actors+  , psmell :: !PerceptionVisible  -- ^ sum over actors that can smell   }   deriving (Show, Eq, Generic) @@ -72,52 +62,23 @@ smellVisible :: Perception -> ES.EnumSet Point smellVisible = pvisible . psmell --- | Whether an actor can see a position.-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- nullPer :: Perception -> Bool-nullPer per = ES.null (totalVisible per)+nullPer per = ES.null (totalVisible per) && ES.null (smellVisible per)  addPer :: Perception -> Perception -> Perception addPer per1 per2 =-  let f :: (PerceptionVisible -> PerceptionVisible -> PerceptionVisible)-      f pv1 pv2 = PerceptionVisible $ pvisible pv1 `ES.union` pvisible pv2-  in Perception-       { perActor = EM.unionWith f (perActor per1) (perActor per2)-       , ptotal = PerceptionVisible-                  $ totalVisible per1 `ES.union` totalVisible per2-       , psmell = PerceptionVisible-                  $ smellVisible per1 `ES.union` smellVisible per2-       }+  Perception+    { ptotal = PerceptionVisible+               $ totalVisible per1 `ES.union` totalVisible per2+    , psmell = PerceptionVisible+               $ smellVisible per1 `ES.union` smellVisible per2+    }  diffPer :: Perception -> Perception -> Perception diffPer per1 per2 =-  let f :: (PerceptionVisible -> PerceptionVisible -> Maybe PerceptionVisible)-      f pv1 pv2 =-        let diff = pvisible pv1 ES.\\ pvisible pv2-        in if ES.null diff then Nothing else Just $ PerceptionVisible diff-  in Perception-       { perActor = EM.differenceWith f (perActor per1) (perActor per2)-       , ptotal = PerceptionVisible-                  $ totalVisible per1 ES.\\ totalVisible per2-       , psmell = PerceptionVisible-                  $ smellVisible per1 ES.\\ smellVisible per2-       }--smellFromActors :: Kind.COps -> State -> PerActor -> PerceptionVisible-smellFromActors Kind.COps{coactor=Kind.Ops{okind}} s perActor =-  let actorCanSmell aid =-        -- If actor is just created, it can already be in Perception-        -- sent to the client, but not in the client's state.-        -- We assume the actor's nose doesn't work yet on first turn.-        -- TODO: assume so on the server, too, or overhaul smelling again.-        not (EM.notMember aid $ sactorD s)-        && let b = getActorBody aid s-           in asmell $ okind $ bkind b-      visSmell = filter (actorCanSmell . fst) $ EM.assocs perActor-      setSmell = map (pvisible . snd) visSmell-  in PerceptionVisible $ ES.unions setSmell+  Perception+    { ptotal = PerceptionVisible+               $ totalVisible per1 ES.\\ totalVisible per2+    , psmell = PerceptionVisible+               $ smellVisible per1 ES.\\ smellVisible per2+    }
Game/LambdaHack/Common/Point.hs view
@@ -1,113 +1,136 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Basic operations on 2D points represented as linear offsets. module Game.LambdaHack.Common.Point-  ( Point, toPoint, showPoint-  , origin, chessDist, adjacent, vicinity, vicinityCardinal-  , inside, displacementXYZ, bla+  ( X, Y, Point(..), maxLevelDimExponent+  , chessDist, euclidDistSq, adjacent, inside, bla, fromTo   ) where +import Control.Exception.Assert.Sugar import Data.Binary-import qualified Data.Ix as Ix-import qualified Data.List as L-import Data.Text (Text)-import qualified System.Random as R+import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.))+import Data.Int (Int32) -import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.PointXY-import Game.LambdaHack.Common.VectorXY-import Control.Exception.Assert.Sugar+-- | Spacial dimension for points and vectors.+type X = Int --- | The type of positions on the 2D level map, heavily optimized.------ We represent the (level map on the) screen as a linear framebuffer,--- where @Point@ is an @Int@ offset counted from the first cell.--- We do bounds check for the X size whenever we convert--- between representations and each subsequent array access--- performs another check, effectively for Y size.--- After dungeon is generated (using @PointXY@, not @Point@),--- and converted to the @Point@ representation, points are used--- mainly as keys and not constructed often, so the performance will improve--- due to smaller save files, the use of @EnumMap@ and cheaper array indexing,--- including cheaper bounds checks.-newtype Point = Point Int-  deriving (Eq, Ord, Ix.Ix, Enum, R.Random)+-- | Spacial dimension for points and vectors.+type Y = Int -instance Binary Point where-  put (Point n) = put n-  get = fmap Point get+-- | 2D points in cartesian representation. Coordinates grow to the right+-- and down, so that the (0, 0) point is in the top-left corner of the screen.+-- Coordinates are never negative.+data Point = Point+  { px :: !X+  , py :: !Y+  }+  deriving (Eq, Ord) --- For debugging. instance Show Point where-  show (Point n) = show n+  show (Point x y) = show (x, y) --- | Print a point as a tuple of cartesian coordinates.-showPoint :: X -> Point -> Text-showPoint lxsize = showT . fromPoint lxsize+instance Binary Point where+  put = put . (fromIntegral :: Int -> Int32) . fromEnum+  get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get --- | Conversion from cartesian coordinates to @Point@.-toPoint :: X -> PointXY -> Point-toPoint lxsize (PointXY (x, y)) =-  assert (lxsize > x && x >= 0 && y >= 0 `blame` "invalid point coordinates"-                                         `twith` (lxsize, x, y))-  $ Point $ x + y * lxsize+-- This conversion cannot be used for PointArray indexing,+-- because it is not contiguous --- we don't know the horizontal+-- width of the levels nor of the screen.+-- The conversion is implemented mainly for @EnumMap@ and @EnumSet@.+instance Enum Point where+  fromEnum = fromEnumPoint+  toEnum = toEnumPoint --- | Conversion from @Point@ to cartesian coordinates.-fromPoint :: X -> Point -> PointXY-fromPoint lxsize (Point p) =-  assert (p >= 0 `blame` "negative point value" `twith` (lxsize, p))-  $ PointXY (p `rem` lxsize, p `quot` lxsize)+-- | The maximum number of bits for level X and Y dimension (16).+-- The value is chosen to support architectures with 32-bit Ints.+maxLevelDimExponent :: Int+{-# INLINE maxLevelDimExponent #-}+maxLevelDimExponent = 16 --- | The top-left corner position of the level.-origin :: Point-origin = Point 0+-- | Maximal supported level X and Y dimension. Not checked anywhere.+-- The value is chosen to support architectures with 32-bit Ints.+maxLevelDim :: Int+{-# INLINE maxLevelDim #-}+maxLevelDim = 2 ^ maxLevelDimExponent - 1 +fromEnumPoint :: Point -> Int+{-# INLINE fromEnumPoint #-}+fromEnumPoint (Point x y) =+  assert (x >= 0 && y >= 0 `blame` "invalid point coordinates"+                           `twith` (x, y))+  $ x + unsafeShiftL y maxLevelDimExponent++toEnumPoint :: Int -> Point+{-# INLINE toEnumPoint #-}+toEnumPoint n =+  Point (n .&. maxLevelDim) (unsafeShiftR n maxLevelDimExponent)+ -- | The distance between two points in the chessboard metric.-chessDist :: X -> Point -> Point -> Int-chessDist lxsize pos0 pos1-  | PointXY (x0, y0) <- fromPoint lxsize pos0-  , PointXY (x1, y1) <- fromPoint lxsize pos1 =-  chessDistXY $ VectorXY (x1 - x0, y1 - y0)+chessDist :: Point -> Point -> Int+{-# INLINE chessDist #-}+chessDist (Point x0 y0) (Point x1 y1) = max (abs (x1 - x0)) (abs (y1 - y0)) +-- | Squared euclidean distance between two points.+euclidDistSq :: Point -> Point -> Int+{-# INLINE euclidDistSq #-}+euclidDistSq (Point x0 y0) (Point x1 y1) =+  let square n = n ^ (2 :: Int)+  in square (x1 - x0) + square (y1 - y0)+ -- | Checks whether two points are adjacent on the map -- (horizontally, vertically or diagonally).-adjacent :: X -> Point -> Point -> Bool-adjacent lxsize s t = chessDist lxsize s t == 1---- | Returns the 8, or less, surrounding positions of a given position.-vicinity :: X -> Y -> Point -> [Point]-vicinity lxsize lysize p =-  map (toPoint lxsize) $-    vicinityXY (0, 0, lxsize - 1, lysize - 1) $-      fromPoint lxsize p---- | Returns the 4, or less, surrounding positions in cardinal directions--- from a given position.-vicinityCardinal :: X -> Y -> Point -> [Point]-vicinityCardinal lxsize lysize p =-  map (toPoint lxsize) $-    vicinityCardinalXY (0, 0, lxsize - 1, lysize - 1) $-      fromPoint lxsize p+adjacent :: Point -> Point -> Bool+{-# INLINE adjacent #-}+adjacent s t = chessDist s t == 1  -- | Checks that a point belongs to an area.-inside :: X -> Point -> (X, Y, X, Y) -> Bool-inside lxsize p = insideXY $ fromPoint lxsize p---- | Calculate the displacement vector from a position to another.-displacementXYZ :: X -> Point -> Point -> VectorXY-displacementXYZ lxsize pos0 pos1-  | PointXY (x0, y0) <- fromPoint lxsize pos0-  , PointXY (x1, y1) <- fromPoint lxsize pos1 =-  VectorXY (x1 - x0, y1 - y0)+inside :: Point -> (X, Y, X, Y) -> Bool+{-# INLINE inside #-}+inside (Point x y) (x0, y0, x1, y1) = x1 >= x && x >= x0 && y1 >= y && y >= y0  -- | Bresenham's line algorithm generalized to arbitrary starting @eps@ -- (@eps@ value of 0 gives the standard BLA). -- Skips the source point and goes through the second point -- to the edge of the level. GIves @Nothing@ if the points are equal.+-- The target is given as @Point@ to permit aiming out of the level,+-- e.g., to get uniform distributions of directions for explosions+-- close to the edge of the level. bla :: X -> Y -> Int -> Point -> Point -> Maybe [Point]-bla _ _ _ source target | source == target = Nothing-bla lxsize lysize eps source target = Just $-  let s = fromPoint lxsize source-      e = fromPoint lxsize target-      inBounds p@(PointXY (x, y)) =-        lxsize > x && x >= 0 && lysize > y && y >= 0 && p /= s-  in L.map (toPoint lxsize) $ L.takeWhile inBounds $ L.tail $ blaXY eps s e+bla lxsize lysize eps source target =+  if source == target then Nothing+  else Just $+    let inBounds p@(Point x y) =+          lxsize > x && x >= 0 && lysize > y && y >= 0 && p /= source+    in takeWhile inBounds $ tail $ blaXY eps source target++-- | Bresenham's line algorithm generalized to arbitrary starting @eps@+-- (@eps@ value of 0 gives the standard BLA). Includes the source point+-- and goes through the target point to infinity.+blaXY :: Int -> Point -> Point -> [Point]+blaXY eps (Point x0 y0) (Point x1 y1) =+  let (dx, dy) = (x1 - x0, y1 - y0)+      xyStep b (x, y) = (x + signum dx,     y + signum dy * b)+      yxStep b (x, y) = (x + signum dx * b, y + signum dy)+      (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep)+                   | otherwise       = (abs dx, abs dy, yxStep)+      bw = balancedWord p q (eps `mod` max 1 q)+      walk w xy = xy : walk (tail w) (step (head w) xy)+  in map (uncurry Point) $ walk bw (x0, y0)++-- | See <http://roguebasin.roguelikedevelopment.org/index.php/Digital_lines>.+balancedWord :: Int -> Int -> Int -> [Int]+balancedWord p q eps | eps + p < q = 0 : balancedWord p q (eps + p)+balancedWord p q eps               = 1 : balancedWord p q (eps + p - q)++-- | A list of all points on a straight vertical or straight horizontal line+-- between two points. Fails if no such line exists.+fromTo :: Point -> Point -> [Point]+fromTo (Point x0 y0) (Point x1 y1) =+ let fromTo1 :: Int -> Int -> [Int]+     fromTo1 z0 z1+       | z0 <= z1  = [z0..z1]+       | otherwise = [z0,z0-1..z1]+     result+       | x0 == x1 = map (\ y -> Point x0 y) (fromTo1 y0 y1)+       | y0 == y1 = map (\ x -> Point x y0) (fromTo1 x0 x1)+       | otherwise = assert `failure` "diagonal fromTo"+                            `twith` ((x0, y0), (x1, y1))+ in result
+ Game/LambdaHack/Common/PointArray.hs view
@@ -0,0 +1,133 @@+-- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@.+module Game.LambdaHack.Common.PointArray+  ( Array+  , (!), (//), replicateA, replicateMA, generateMA, sizeA+  , foldlA, ifoldlA, minIndexA, minLastIndexA, maxIndexA, maxLastIndexA+  ) where++import Control.Arrow ((***))+import Control.Monad+import Data.Binary+import Data.Vector.Binary ()+import qualified Data.Vector.Fusion.Stream as Stream+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U++import Game.LambdaHack.Common.Point++-- TODO: for now, until there's support for GeneralizedNewtypeDeriving+-- for Unboxed, there's a lot of @Word8@ in place of @c@ here+-- and a contraint @Enum c@ instead of @Unbox c@.++-- TODO: perhaps make them an instance of Data.Vector.Generic?+-- | Arrays indexed by @Point@.+data Array c = Array+  { axsize  :: X+  , aysize  :: Y+  , avector :: U.Vector Word8+  }+  deriving Eq++instance Show (Array c) where+  show a = "PointArray.Array with size " ++ show (sizeA a)++cnv :: (Enum a, Enum b) => a -> b+cnv = toEnum . fromEnum++pindex :: X -> Point -> Int+pindex xsize (Point x y) = x + y * xsize++punindex :: X -> Int -> Point+punindex xsize n = let (y, x) = n `quotRem` xsize+                   in Point x y++-- Note: there's no point specializing this to @Point@ arguments,+-- since the extra few additions in @fromPoint@ may be less expensive than+-- memory or register allocations needed for the extra @Int@ in @Point@.+-- | Array lookup.+(!) :: Enum c => Array c -> Point -> c+{-# INLINE (!) #-}+(!) Array{..} p = cnv $ avector U.! pindex axsize p++-- | Construct an array updated with the association list.+(//) :: Enum c => Array c -> [(Point, c)] -> Array c+(//) Array{..} l = let v = avector U.// map (pindex axsize *** cnv) l+                   in Array{avector = v, ..}++-- | Create an array from a replicated element.+replicateA :: Enum c => X -> Y -> c -> Array c+replicateA axsize aysize c =+  Array{avector = U.replicate (axsize * aysize) $ cnv c, ..}++-- | Create an  array from a replicated monadic action.+replicateMA :: Enum c => Monad m => X -> Y -> m c -> m (Array c)+replicateMA axsize aysize m = do+  v <- U.replicateM (axsize * aysize) $ liftM cnv m+  return $! Array{avector = v, ..}++-- | Create an array from a monadic function.+generateMA :: Enum c => Monad m => X -> Y -> (Point -> m c) -> m (Array c)+generateMA axsize aysize fm = do+  let gm n = liftM cnv $ fm $ punindex axsize n+  v <- U.generateM (axsize * aysize) gm+  return $! Array{avector = v, ..}++-- | Content identifiers array size.+sizeA :: Array c -> (X, Y)+sizeA Array{..} = (axsize, aysize)++-- | Fold left strictly over an array.+foldlA :: Enum c => (a -> c -> a) -> a -> Array c -> a+foldlA f z0 Array{..} =+  U.foldl' (\a c -> f a (cnv c)) z0 avector++-- | Fold left strictly over an array+-- (function applied to each element and its index).+ifoldlA :: Enum c => (a -> Point -> c -> a) -> a -> Array c -> a+ifoldlA f z0 Array{..} =+  U.ifoldl' (\a n c -> f a (punindex axsize n) (cnv c)) z0 avector++-- | Yield the point coordinates of a minimum element of the array.+-- The array may not be empty.+minIndexA :: Enum c => Array c -> Point+{-# INLINE minIndexA #-}+minIndexA Array{..} = punindex axsize $ U.minIndex avector++-- | Yield the point coordinates of the last minimum element of the array.+-- The array may not be empty.+minLastIndexA :: Enum c => Array c -> Point+{-# INLINE minLastIndexA #-}+minLastIndexA Array{..} =+  punindex axsize+  $ fst . Stream.foldl1' imin . Stream.indexed . G.stream+  $ avector+ where+  imin (i, x) (j, y) = i `seq` j `seq` if x >= y then (j, y) else (i, x)++-- | Yield the point coordinates of the first maximum element of the array.+-- The array may not be empty.+maxIndexA :: Enum c => Array c -> Point+{-# INLINE maxIndexA #-}+maxIndexA Array{..} = punindex axsize $ U.maxIndex avector++-- | Yield the point coordinates of the last maximum element of the array.+-- The array may not be empty.+maxLastIndexA :: Enum c => Array c -> Point+{-# INLINE maxLastIndexA #-}+maxLastIndexA Array{..} =+  punindex axsize+  $ fst . Stream.foldl1' imax . Stream.indexed . G.stream+  $ avector+ where+  imax (i, x) (j, y) = i `seq` j `seq` if x <= y then (j, y) else (i, x)++instance Binary (Array c) where+  put Array{..} = do+    put axsize+    put aysize+    put avector+  get = do+    axsize <- get+    aysize <- get+    avector <- get+    return $! Array{..}
− Game/LambdaHack/Common/PointXY.hs 
@@ -1,79 +0,0 @@--- | Basic cartesian geometry operations on 2D points.-module Game.LambdaHack.Common.PointXY-  ( X, Y, PointXY(..), fromTo, sortPointXY, blaXY, insideXY-  ) where--import qualified Data.List as L--import Game.LambdaHack.Common.Misc-import Control.Exception.Assert.Sugar---- | Spacial dimension for points and vectors.-type X = Int---- | Spacial dimension for points and vectors.-type Y = Int---- | 2D points in cartesian representation.-newtype PointXY = PointXY (X, Y)-  deriving (Eq, Ord)--instance Show PointXY where-  show (PointXY (x, y)) = show (x, y)---- TODO: perhaps use this instead of Point, but then @shift@ is not longer--- so cheap, and we need, e.g., an extra addition per FOV point and per--- AI speculative move. Additions are cheap though and code would be--- shorter thanks to removing the lxsize argument in many places.--- More serious is one addition and one multiplication per EnumMap lookup,--- though in the computation-intensive cases of FOV and AI, the extra--- operations were already there, performed before lookup.--- TODO: rem and quot by 2^w can probably be optimised-instance Enum PointXY where-  toEnum p = PointXY (p `rem` maxLevelDim, p `quot` maxLevelDim)-  fromEnum (PointXY (x, y)) = x + y * maxLevelDim---- | A list of all points on a straight vertical or straight horizontal line--- between two points. Fails if no such line exists.-fromTo :: PointXY -> PointXY -> [PointXY]-fromTo (PointXY (x0, y0)) (PointXY (x1, y1)) =- 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` "diagononal fromTo"-                            `twith` ((x0, y0), (x1, y1))- in result--fromTo1 :: Int -> Int -> [Int]-fromTo1 x0 x1-  | x0 <= x1  = [x0..x1]-  | otherwise = [x0,x0-1..x1]---- | Sort the sequence of two points, in the derived lexicographic order.-sortPointXY :: (PointXY, PointXY) -> (PointXY, PointXY)-sortPointXY (a, b) | a <= b    = (a, b)-                   | otherwise = (b, a)---- | See <http://roguebasin.roguelikedevelopment.org/index.php/Digital_lines>.-balancedWord :: Int -> Int -> Int -> [Int]-balancedWord p q eps | eps + p < q = 0 : balancedWord p q (eps + p)-balancedWord p q eps               = 1 : balancedWord p q (eps + p - q)---- | Bresenham's line algorithm generalized to arbitrary starting @eps@--- (@eps@ value of 0 gives the standard BLA). Includes the source point--- and goes through the target point to infinity.-blaXY :: Int -> PointXY -> PointXY -> [PointXY]-blaXY eps (PointXY (x0, y0)) (PointXY (x1, y1)) =-  let (dx, dy) = (x1 - x0, y1 - y0)-      xyStep b (x, y) = (x + signum dx,     y + signum dy * b)-      yxStep b (x, y) = (x + signum dx * b, y + signum dy)-      (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep)-                   | otherwise       = (abs dx, abs dy, yxStep)-      bw = balancedWord p q (eps `mod` max 1 q)-      walk w xy = xy : walk (tail w) (step (head w) xy)-  in L.map PointXY $ walk bw (x0, y0)---- | Checks that a point belongs to an area.-insideXY :: PointXY -> (X, Y, X, Y) -> Bool-insideXY (PointXY (x, y)) (x0, y0, x1, y1) =-  x1 >= x && x >= x0 && y1 >= y && y >= y0
Game/LambdaHack/Common/Random.hs view
@@ -17,17 +17,15 @@   , rndToIO   ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St import Data.Binary-import qualified Data.Binary as Binary import qualified Data.Hashable as Hashable-import qualified Data.List as L import Data.Ratio import GHC.Generics (Generic) import qualified System.Random as R -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency  -- | The monad of computations with random generator state.@@ -59,7 +57,7 @@  -- | 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 !Word8 !Word8   deriving (Eq, Ord, Generic)  instance Show RollDice where@@ -67,7 +65,7 @@  instance Read RollDice where   readsPrec d s =-    let (a, db) = L.break (== 'd') s+    let (a, db) = break (== 'd') s         av = read a     in case db of       'd' : b -> [ (RollDice av bv, rest) | (bv, rest) <- readsPrec d b ]@@ -84,7 +82,7 @@  -- | Cast dice and sum the results. castDice :: RollDice -> Rnd Int-castDice (RollDice a' 1)  = return $ fromEnum a'  -- optimization+castDice (RollDice a' 1)  = return $! fromEnum a'  -- optimization castDice (RollDice a' b') =   let (a, b) = (fromEnum a', fromEnum b')   in liftM sum (replicateM a (cast b))@@ -139,8 +137,10 @@ -- To the result of rolling the first set of dice we add the second, -- scaled in proportion to current depth divided by maximal dungeon depth. data RollDeep = RollDeep !RollDice !RollDice-  deriving Show+  deriving (Show, Eq, Ord, Generic) +instance Binary RollDeep+ rollDeep :: (Int, Int) -> (Int, Int) -> RollDeep rollDeep (a, b) (c, d) = RollDeep (rollDice a b) (rollDice c d) @@ -154,7 +154,7 @@                               `twith` (n, depth)) skip   r1 <- castDice d1   r2 <- castDice d2-  return $ r1 + ((n - 1) * r2) `div` max 1 (depth - 1)+  return $! r1 + ((n - 1) * r2) `div` max 1 (depth - 1)  -- | Cast dice scaled with current level depth and return @True@ -- if the results if greater than 50.@@ -163,15 +163,16 @@   let n = abs n'       depth = abs depth'   c <- castDeep n depth deep-  return $ c > 50+  return $! c > 50  -- | Generate a @RollDeep@ that always gives a constant integer. intToDeep :: Int -> RollDeep intToDeep 0  = RollDeep (RollDice 0 0) (RollDice 0 0)-intToDeep n' = let n = toEnum n'-               in if n > maxBound || n < minBound-                  then assert `failure` "Deep out of bound" `twith` n'-                  else RollDeep (RollDice n 1) (RollDice 0 0)+intToDeep n' = if n' > fromEnum (maxBound :: Word8)+                  || n' < fromEnum (minBound :: Word8)+               then assert `failure` "Deep out of bound" `twith` n'+               else let n = toEnum n'+                    in RollDeep (RollDice n 1) (RollDice 0 0)  -- | Maximal value of scaled dice. maxDeep :: RollDeep -> Int
Game/LambdaHack/Common/Save.hs view
@@ -45,7 +45,9 @@     ms <- takeMVar toSave     case ms of       Just s -> do-        encodeEOF (saveFile s) s+        dataDir <- appDataDir+        tryCreateDir (dataDir </> "saves")+        encodeEOF (dataDir </> "saves" </> saveFile s) s         -- Wait until the save finished. During that time, the mvar         -- is continually updated to newest state values.         loop@@ -77,14 +79,14 @@ -- | 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)+            => String -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath)             -> IO (Maybe a)-restoreGame name configAppDataDir copies pathsDataFile = do+restoreGame name copies pathsDataFile = do   -- Create user data directory and copy files, if not already there.-  tryCreateDir configAppDataDir-  tryCopyDataFiles configAppDataDir pathsDataFile copies-  let saveFile = configAppDataDir </> name+  dataDir <- appDataDir+  tryCreateDir dataDir+  tryCopyDataFiles dataDir pathsDataFile copies+  let saveFile = dataDir </> "saves" </> 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@@ -99,7 +101,7 @@   let handler :: Ex.SomeException -> IO (Maybe a)       handler e = do         let msg = "Restore failed. The error message is:"-                  <+> (T.unwords . T.lines) (showT e)+                  <+> (T.unwords . T.lines) (tshow e)         delayPrint $ msg         return Nothing   either handler return res
Game/LambdaHack/Common/ServerCmd.hs view
@@ -2,7 +2,7 @@ -- See -- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Common.ServerCmd-  ( CmdSer(..), CmdSerTakeTime(..), aidCmdSer, aidCmdSerTakeTime+  ( CmdSer(..), CmdTakeTimeSer(..), aidCmdSer, aidCmdTakeTimeSer   , FailureSer(..), showFailureSer   ) where @@ -18,76 +18,84 @@  -- | Abstract syntax of server commands. data CmdSer =-    TakeTimeSer !CmdSerTakeTime-  | GameRestartSer !ActorId !Text-  | GameExitSer !ActorId+    CmdTakeTimeSer !CmdTakeTimeSer+  | GameRestartSer !ActorId !Text !Int ![(Int, Text)]+  | GameExitSer !ActorId !Int   | GameSaveSer !ActorId   deriving (Show, Eq) -data CmdSerTakeTime =+data CmdTakeTimeSer =     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+  | PickupSer !ActorId !ItemId !Int+  | DropSer !ActorId !ItemId !Int   | ProjectSer !ActorId !Point !Int !ItemId !Container   | ApplySer !ActorId !ItemId !Container   | TriggerSer !ActorId !(Maybe F.Feature)-  | SetPathSer !ActorId ![Vector]+  | SetTrajectorySer !ActorId   deriving (Show, Eq) --- | The actor that start performing the command (may be dead, after+-- | The actor that starts 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+  CmdTakeTimeSer cmd2 -> aidCmdTakeTimeSer cmd2+  GameRestartSer aid _ _ _ -> aid+  GameExitSer aid _ -> aid   GameSaveSer aid -> aid -aidCmdSerTakeTime :: CmdSerTakeTime -> ActorId-aidCmdSerTakeTime cmd = case cmd of+aidCmdTakeTimeSer :: CmdTakeTimeSer -> ActorId+aidCmdTakeTimeSer cmd = case cmd of   MoveSer aid _ -> aid   MeleeSer aid _ -> aid   DisplaceSer aid _ -> aid   AlterSer aid _ _ -> aid   WaitSer aid -> aid-  PickupSer aid _ _ _ -> aid-  DropSer aid _ -> aid+  PickupSer aid _ _ -> aid+  DropSer aid _ _ -> aid   ProjectSer aid _ _ _ _ -> aid   ApplySer aid _ _ -> aid   TriggerSer aid _ -> aid-  SetPathSer aid _ -> aid+  SetTrajectorySer aid -> aid  data FailureSer =     MoveNothing+  | MeleeSelf   | MeleeDistant   | DisplaceDistant   | DisplaceAccess+  | DisplaceProjectiles   | AlterDistant   | AlterBlockActor   | AlterBlockItem   | AlterNothing+  | PickupOverfull   | ProjectAimOnself   | ProjectBlockTerrain   | ProjectBlockActor   | ProjectBlockFoes+  | ProjectBlind   | TriggerNothing  showFailureSer :: FailureSer -> Msg showFailureSer failureSer = case failureSer of   MoveNothing -> "wasting time on moving into obstacle"+  MeleeSelf -> "trying to melee oneself"   MeleeDistant -> "trying to melee a distant foe"   DisplaceDistant -> "trying to switch places with a distant actor"   DisplaceAccess -> "switching places without access"+  DisplaceProjectiles -> "trying to switch places with multiple projectiles"   AlterDistant -> "trying to alter a distant tile"   AlterBlockActor -> "blocked by an actor"   AlterBlockItem -> "jammed by an item"   AlterNothing -> "wasting time on altering nothing"+  PickupOverfull -> "cannot carry any more"   ProjectAimOnself -> "cannot aim at oneself"   ProjectBlockTerrain -> "aiming obstructed by terrain"   ProjectBlockActor -> "aiming blocked by an actor"   ProjectBlockFoes -> "aiming interrupted by foes"+  ProjectBlind -> "blind actors cannot aim"   TriggerNothing -> "wasting time on triggering nothing"
Game/LambdaHack/Common/State.hs view
@@ -8,7 +8,7 @@   , defStateGlobal, emptyState, localFromGlobal   , updateDungeon, updateDepth, updateActorD, updateItemD   , updateFaction, updateTime, updateCOps, getLocalTime-  , isSpawnFaction, isSummonFaction+  , isSpawnFaction   ) where  import Data.Binary@@ -21,7 +21,7 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY+import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Utils.Frequency@@ -44,17 +44,18 @@ -- 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 -> Int -> Int+             -> Text -> ([Point], [Point]) -> Int -> Int -> Int -> Bool              -> Level unknownLevel Kind.Ops{ouniqGroup} ldepth lxsize lysize ldesc lstair lclear-             lsecret lhidden =+             lsecret lhidden lescape =   let unknownId = ouniqGroup "unknown space"+      outerId = ouniqGroup "basic outer fence"   in Level { ldepth            , lprio = EM.empty            , lfloor = EM.empty-           , ltile = unknownTileMap unknownId lxsize lysize-           , lxsize = lxsize-           , lysize = lysize+           , ltile = unknownTileMap unknownId outerId lxsize lysize+           , lxsize+           , lysize            , lsmell = EM.empty            , ldesc            , lstair@@ -65,12 +66,18 @@            , litemFreq = toFreq "client item freq" []            , lsecret            , lhidden+           , lescape            } -unknownTileMap :: Kind.Id TileKind -> Int -> Int -> TileMap-unknownTileMap unknownId cxsize cysize =-  let bounds = (origin, toPoint cxsize $ PointXY (cxsize - 1, cysize - 1))-  in Kind.listArray bounds (repeat unknownId)+unknownTileMap :: Kind.Id TileKind -> Kind.Id TileKind -> Int -> Int -> TileMap+unknownTileMap unknownId outerId lxsize lysize =+  let unknownMap = PointArray.replicateA lxsize lysize unknownId+      borders = [ Point x y+                | x <- [0, lxsize - 1], y <- [1..lysize - 2] ]+                ++ [ Point x y+                   | x <- [0..lxsize - 1], y <- [0, lysize - 1] ]+      outerUpdate = zip borders $ repeat outerId+  in unknownMap PointArray.// outerUpdate  -- | Initial complete global game state. defStateGlobal :: Dungeon -> Int@@ -109,7 +116,7 @@     { _sdungeon =       EM.map (\Level{..} ->               unknownLevel cotile ldepth lxsize lysize ldesc lstair lclear-                           lsecret lhidden)+                           lsecret lhidden lescape)             _sdungeon     , ..     }@@ -148,11 +155,7 @@  -- | Tell whether the faction can spawn actors. isSpawnFaction :: FactionId -> State -> Bool-isSpawnFaction fid s = isSpawnFact (_scops s) $ _sfactionD s EM.! fid---- | Tell whether actors of the faction can be summoned by items, etc..-isSummonFaction :: FactionId -> State -> Bool-isSummonFaction fid s = isSummonFact (_scops s) $ _sfactionD s EM.! fid+isSpawnFaction fid s = isSpawnFact $ _sfactionD s EM.! fid  sdungeon :: State -> Dungeon sdungeon = _sdungeon@@ -196,4 +199,4 @@     _stime <- get     _shigh <- get     let _scops = undefined  -- overwritten by recreated cops-    return State{..}+    return $! State{..}
Game/LambdaHack/Common/Tile.hs view
@@ -14,21 +14,22 @@ -- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). module Game.LambdaHack.Common.Tile   ( SmellTime-  , kindHasFeature, kindHas, hasFeature-  , isClear, isLit, isExplorable, similar, speedup-  , openTo, closeTo, revealAs, hideAs, openable, closable, changeable+  , kindHasFeature, hasFeature+  , isClear, isLit, isWalkable, isPassable, isDoor, isSuspect+  , isExplorable, lookSimilar, speedup+  , openTo, closeTo, causeEffects, revealAs, hideAs+  , isOpenable, isClosable, isChangeable, isEscape, isStair   ) where -import qualified Data.Array.Unboxed as A-import qualified Data.List as L+import Control.Exception.Assert.Sugar import Data.Maybe +import qualified Game.LambdaHack.Common.Effect as Effect 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 Control.Exception.Assert.Sugar  -- | The last time a hero left a smell in a given tile. To be used -- by monsters that hunt by smell.@@ -36,57 +37,101 @@  -- | Whether a tile kind has the given feature. kindHasFeature :: F.Feature -> TileKind -> Bool+{-# INLINE kindHasFeature #-} kindHasFeature f t = f `elem` tfeature t --- | Whether a tile kind has all features of the first set--- and no features of the second.-kindHas :: [F.Feature] -> [F.Feature] -> TileKind -> Bool-kindHas yes no t = L.all (`kindHasFeature` t) yes-                   && not (L.any (`kindHasFeature` t) no)- -- | Whether a tile kind (specified by its id) has the given feature. hasFeature :: Kind.Ops TileKind -> F.Feature -> Kind.Id TileKind -> Bool-hasFeature Kind.Ops{okind} f t =-  kindHasFeature f (okind t)+{-# INLINE hasFeature #-}+hasFeature Kind.Ops{okind} f t = kindHasFeature f (okind t)  -- | 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 = Just Kind.TileSpeedup{isClearTab}} = isClearTab+{-# INLINE isClear #-}+isClear Kind.Ops{ospeedup = Just Kind.TileSpeedup{isClearTab}} =+  \k -> Kind.accessTab isClearTab k isClear cotile = assert `failure` "no speedup" `twith` 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 = Just Kind.TileSpeedup{isLitTab}} = isLitTab+{-# INLINE isLit #-}+isLit Kind.Ops{ospeedup = Just Kind.TileSpeedup{isLitTab}} =+  \k -> Kind.accessTab isLitTab k isLit cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile --- | Whether a tile can be explored, possibly yielding a treasure--- or a hidden message.+-- | Whether actors can walk into a tile.+-- Essential for efficiency of pathfinding, hence tabulated.+isWalkable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+{-# INLINE isWalkable #-}+isWalkable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isWalkableTab}} =+  \k -> Kind.accessTab isWalkableTab k+isWalkable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile++-- | Whether actors can walk into a tile, perhaps opening a door first.+-- Essential for efficiency of pathfinding, hence tabulated.+isPassable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+{-# INLINE isPassable #-}+isPassable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isPassableTab}} =+  \k -> Kind.accessTab isPassableTab k+isPassable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile++-- | Whether a tile is a door, open or closed.+-- Essential for efficiency of pathfinding, hence tabulated.+isDoor :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+{-# INLINE isDoor #-}+isDoor Kind.Ops{ospeedup = Just Kind.TileSpeedup{isDoorTab}} =+  \k -> Kind.accessTab isDoorTab k+isDoor cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile++-- | Whether a tile is suspect.+-- Essential for efficiency of pathfinding, hence tabulated.+isSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+{-# INLINE isSuspect #-}+isSuspect Kind.Ops{ospeedup = Just Kind.TileSpeedup{isSuspectTab}} =+  \k -> Kind.accessTab isSuspectTab k+isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile++-- | Whether a tile can be explored, possibly yielding a treasure.+-- Note that non-walkable tiles can hold treasure, e.g., caches. isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isExplorable cops tk = isClear cops tk || hasFeature cops F.Walkable tk+{-# INLINE isExplorable #-}+isExplorable cotile t =+  isWalkable cotile t || isDoor cotile t || isChangeable cotile t  -- | The player can't tell one tile from the other.-similar :: TileKind -> TileKind -> Bool-similar t u =+lookSimilar :: TileKind -> TileKind -> Bool+{-# INLINE lookSimilar #-}+lookSimilar t u =   tsymbol t == tsymbol u &&   tname   t == tname   u &&   tcolor  t == tcolor  u &&   tcolor2 t == tcolor2 u  speedup :: Bool -> Kind.Ops TileKind -> Kind.Speedup TileKind-speedup allClear Kind.Ops{ofoldrWithKey, obounds} =-  let createTab :: (TileKind -> Bool) -> A.UArray (Kind.Id TileKind) Bool-      createTab p =-        let f _ k acc = p k : acc-            clearAssocs = ofoldrWithKey f []-        in A.listArray obounds clearAssocs-      tabulate :: (TileKind -> Bool) -> Kind.Id TileKind -> Bool-      tabulate p = (createTab p A.!)-      isClearTab | allClear = tabulate $ not . kindHasFeature F.Impenetrable-                 | otherwise = tabulate $ kindHasFeature F.Clear-      isLitTab   = tabulate $ kindHasFeature F.Lit-  in Kind.TileSpeedup {isClearTab, isLitTab}+speedup allClear cotile =+  -- Vectors pack bools as Word8 by default. No idea if the extra memory+  -- taken makes random lookups more or less efficient, so not optimizing+  -- further, until I have benchmarks.+  let isClearTab | allClear = Kind.createTab cotile+                              $ not . kindHasFeature F.Impenetrable+                 | otherwise = Kind.createTab cotile+                               $ kindHasFeature F.Clear+      isLitTab = Kind.createTab cotile $ not . kindHasFeature F.Dark+      isWalkableTab = Kind.createTab cotile $ kindHasFeature F.Walkable+      isPassableTab = Kind.createTab cotile $ \tk ->+        let getTo F.OpenTo{} = True+            getTo F.Walkable = True+            getTo _ = False+        in any getTo $ tfeature tk+      isDoorTab = Kind.createTab cotile $ \tk ->+        let getTo F.OpenTo{} = True+            getTo F.CloseTo{} = True+            getTo _ = False+        in any getTo $ tfeature tk+      isSuspectTab = Kind.createTab cotile $ kindHasFeature F.Suspect+  in Kind.TileSpeedup {..}  openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) openTo Kind.Ops{okind, opick} t = do@@ -110,6 +155,12 @@       fmap (fromMaybe $ assert `failure` group)         $ opick group (const True) +causeEffects :: Kind.Ops TileKind -> Kind.Id TileKind -> [Effect.Effect Int]+causeEffects Kind.Ops{okind} t = do+  let getTo (F.Cause eff) acc = eff : acc+      getTo _ acc = acc+  foldr getTo [] $ tfeature $ okind t+ 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@@ -129,23 +180,33 @@        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 =+-- | Whether a tile kind (specified by its id) has an OpenTo feature.+isOpenable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isOpenable 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 =+isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isClosable 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 =+isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isChangeable Kind.Ops{okind} t =   let getTo F.ChangeTo{} = True       getTo _ = False   in any getTo $ tfeature $ okind t++isEscape :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isEscape cotile t = let isEffectEscape Effect.Escape{} = True+                        isEffectEscape _ = False+                    in any isEffectEscape $ causeEffects cotile t++isStair :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+isStair cotile t = let isEffectAscend Effect.Ascend{} = True+                       isEffectAscend _ = False+                   in any isEffectAscend $ causeEffects cotile t
Game/LambdaHack/Common/Time.hs view
@@ -5,13 +5,15 @@   , timeAdd, timeFit, timeNegate, timeScale, timeEpsilon   , timeToDigit   , Speed, toSpeed, speedZero, speedNormal, speedScale, speedAdd, speedNegate-  , ticksPerMeter, traveled, speedFromWeight, rangeFromSpeed+  , ticksPerMeter, speedFromWeight, rangeFromSpeed   ) where  import Data.Binary import qualified Data.Char as Char import Data.Int (Int64) +import Game.LambdaHack.Common.Misc+ -- | Game time in ticks. The time dimension. -- One tick is 1 microsecond (one millionth of a second), -- one turn is 0.5 s.@@ -100,7 +102,7 @@   put (Speed n) = put n   get = fmap Speed get --- | Number of seconds in a kilo-second.+-- | Number of seconds in a mega-second. sInMs :: Int64 sInMs = 1000000 @@ -130,13 +132,7 @@  -- | The number of time ticks it takes to walk 1 meter at the given speed. ticksPerMeter :: Speed -> Time-ticksPerMeter (Speed v) = Time $ _ticksInSecond * sInMs `div` v---- | Distance in meters (so also in tiles, given the chess metric)--- traveled in a given time by a body with a given speed.-traveled :: Speed -> Time -> Int-traveled (Speed v) (Time t) =-  fromIntegral $ v * t `div` (_ticksInSecond * sInMs)+ticksPerMeter (Speed v) = Time $ _ticksInSecond * sInMs `divUp` v  -- | Calculate projectile speed from item weight in grams -- and speed bonus in percents.@@ -148,13 +144,16 @@       mpMs | w <= 500 = sInMs * 16            | w > 500 && w <= 2000 = sInMs * 16 * 1500 `div` (w + 1000)            | otherwise = sInMs * (10000 - w) `div` 1000-  in Speed $ max 0 $ mpMs * (100 + b) `div` 100+  in Speed $ max 1 $ mpMs * (100 + b) `div` 100  -- | Calculate maximum range in meters of a projectile from its speed. -- See <https://github.com/kosmikus/LambdaHack/wiki/Item-statistics>.--- With this formula, each projectile flies for exactly one second,+-- With this formula, each projectile flies for at most 1 second, -- that is 2 turns, and then drops to the ground.--- Dividing and multiplying by 2 ensures both turns of flight--- cover the same distance.+-- We round down to the nearest multiple of 2 (unless the speed+-- is very low), to ensure both turns of flight cover the same distance. rangeFromSpeed :: Speed -> Int-rangeFromSpeed (Speed v) = fromIntegral $ 2 * (v `div` (sInMs * 2))+rangeFromSpeed (Speed v) =+  fromIntegral $ if v >= 2 * sInMs+                 then 2 * (v `div` (2 * sInMs))+                 else v `div` sInMs
Game/LambdaHack/Common/Vector.hs view
@@ -1,131 +1,206 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Basic operations on 2D vectors represented in an efficient, -- but not unique, way. module Game.LambdaHack.Common.Vector-  ( Vector, toVector, toDir, shift, shiftBounded, moves-  , isUnit, euclidDistSq, diagonal, neg, towards, displacement-  , displacePath, shiftPath+  ( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector+  , moves, compassText, vicinity, vicinityCardinal+  , shift, shiftBounded, trajectoryToPath, displacement, pathToTrajectory+  , RadianAngle, rotate, towards+  , BfsDistance, MoveLegal(..), apartBfs+  , fillBfs, findPathBfs, accessBfs, posAimsPos   ) where +import Control.Arrow (second)+import Control.Exception.Assert.Sugar import Data.Binary+import Data.Bits (Bits, complement, (.&.), (.|.))+import qualified Data.EnumMap.Strict as EM+import Data.Int (Int32)+import Data.List+import Data.Maybe+import qualified Data.Sequence as Seq+import Data.Text (Text)  import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY-import Game.LambdaHack.Common.VectorXY-import Control.Exception.Assert.Sugar+import qualified Game.LambdaHack.Common.PointArray as PointArray --- | 2D vectors  represented as offsets in the linear framebuffer--- indexed by 'Point'.------ A newtype is used to prevent mixing up the type with @Point@ itself.--- Note that the offset representations of a vector is usually not unique.--- E.g., for vectors of length 1 in the chessboard metric, used to denote--- geographical directions, the representations are pairwise distinct--- if and only if the level width and height are at least 3.-newtype Vector = Vector Int-  deriving (Eq, Ord, Read)+-- | 2D vectors in cartesian representation. Coordinates grow to the right+-- and down, so that the (1, 1) vector points to the bottom-right corner+-- of the screen.+data Vector = Vector+  { vx :: !X+  , vy :: !Y+  }+  deriving (Eq, Ord, Show, Read)  instance Binary Vector where-  put (Vector dir) = put dir-  get = fmap Vector get+  put = put . (fromIntegral :: Int -> Int32) . fromEnum+  get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get --- For debugging.-instance Show Vector where-  show (Vector n) = show n+instance Enum Vector where+  fromEnum = fromEnumVector+  toEnum = toEnumVector --- | Converts a vector in cartesian representation into @Vector@.-toVector :: X -> VectorXY -> Vector-toVector lxsize (VectorXY (x, y)) =-  Vector $ x + y * lxsize+-- | Maximal supported vector X and Y coordinates.+maxVectorDim :: Int+{-# INLINE maxVectorDim #-}+maxVectorDim = 2 ^ (maxLevelDimExponent - 1) - 1 -isUnitXY :: VectorXY -> Bool-isUnitXY v = chessDistXY v == 1+fromEnumVector :: Vector -> Int+{-# INLINE fromEnumVector #-}+fromEnumVector (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent) +toEnumVector :: Int -> Vector+{-# INLINE toEnumVector #-}+toEnumVector n =+  let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent)+      (vx, vy) = if x > maxVectorDim+                 then (x - 2 ^ maxLevelDimExponent, y + 1)+                 else if x < - maxVectorDim+                      then (x + 2 ^ maxLevelDimExponent, y - 1)+                      else (x, y)+  in Vector{..}+ -- | Tells if a vector has length 1 in the chessboard metric.-isUnit ::  X -> Vector -> Bool-isUnit lxsize = isUnitXY . fromDir lxsize+isUnit :: Vector -> Bool+{-# INLINE isUnit #-}+isUnit v = chessDistVector v == 1 --- | 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` "ambiguous XY vector conversion"-                                    `twith` (lxsize, v)) $-  Vector $ x + y * lxsize+-- | Checks whether a unit vector is a diagonal direction,+-- as opposed to cardinal. If the vector is not unit,+-- it checks that the vector is not horizontal nor vertical.+isDiagonal :: Vector -> Bool+{-# INLINE isDiagonal #-}+isDiagonal (Vector x y) = x * y /= 0 --- | Converts a unit vector in the offset representation--- into the cartesian representation. Arbitrary vectors can't be--- converted uniquely.-fromDir :: X -> Vector -> VectorXY-fromDir lxsize (Vector dir) =-  assert (lxsize >= 3 && isUnitXY res &&-          fst len1 + snd len1 * lxsize == dir-          `blame` "ambiguous vector conversion" `twith` (lxsize, dir, res))-  res- where-  (x, y) = (dir `mod` lxsize, dir `div` lxsize)-  -- Pick the vector's canonical form of length 1:-  len1 = if x > 1-         then (x - lxsize, y + 1)-         else (x, y)-  res = VectorXY len1+-- | Reverse an arbirary vector.+neg :: Vector -> Vector+{-# INLINE neg #-}+neg (Vector vx vy) = Vector (-vx) (-vy) +-- | Squared euclidean distance between two vectors.+euclidDistSqVector :: Vector -> Vector -> Int+{-# INLINE euclidDistSqVector #-}+euclidDistSqVector (Vector x0 y0) (Vector x1 y1) =+  let square n = n ^ (2 :: Int)+  in square (x1 - x0) + square (y1 - y0)++-- | The lenght of a vector in the chessboard metric,+-- where diagonal moves cost 1.+chessDistVector :: Vector -> Int+{-# INLINE chessDistVector #-}+chessDistVector (Vector x y) = max (abs x) (abs y)++-- | Vectors of all unit moves in the chessboard metric,+-- clockwise, starting north-west.+moves :: [Vector]+moves =+  map (uncurry Vector)+    [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]++moveTexts :: [Text]+moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"]++compassText :: Vector -> Text+compassText v = let m = EM.fromList $ zip moves moveTexts+                in fromMaybe (assert `failure` "not a unit vector"+                                     `twith` v) $ EM.lookup v m++-- | Vectors of all cardinal direction unit moves, clockwise, starting north.+movesCardinal :: [Vector]+movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)]++-- | All (8 at most) closest neighbours of a point within an area.+vicinity :: X -> Y   -- ^ limit the search to this area+         -> Point    -- ^ position to find neighbours of+         -> [Point]+vicinity lxsize lysize p =+  [ res | dxy <- moves+        , let res = shift p dxy+        , inside res (0, 0, lxsize - 1, lysize - 1) ]++-- | All (4 at most) cardinal direction neighbours of a point within an area.+vicinityCardinal :: X -> Y   -- ^ limit the search to this area+                 -> Point    -- ^ position to find neighbours of+                 -> [Point]+vicinityCardinal lxsize lysize p =+  [ res | dxy <- movesCardinal+        , let res = shift p dxy+        , inside res (0, 0, lxsize - 1, lysize - 1) ]+ -- | Translate a point by a vector.------ Particularly simple and fast implementation in the linear representation. shift :: Point -> Vector -> Point-shift p (Vector dir) = toEnum $ fromEnum p + dir+{-# INLINE shift #-}+shift (Point x0 y0) (Vector x1 y1) = Point (x0 + x1) (y0 + y1)  -- | Translate a point by a vector, but only if the result fits in an area.-shiftBounded :: X -> (X, Y, X, Y) -> Point -> Vector -> Point-shiftBounded lxsize area pos dir =-  let res = shift pos dir-  in if inside lxsize res area then res else pos+shiftBounded :: X -> Y -> Point -> Vector -> Point+shiftBounded lxsize lysize pos v@(Vector xv yv) =+  if inside pos (-xv, -yv, lxsize - xv - 1, lysize - yv - 1)+  then shift pos v+  else pos --- | Vectors of all unit moves, clockwise, starting north-west.-moves :: X -> [Vector]-moves lxsize = map (toDir lxsize) movesXY+-- | A list of points that a list of vectors leads to.+trajectoryToPath :: Point -> [Vector] -> [Point]+trajectoryToPath _ [] = []+trajectoryToPath start (v : vs) = let next = shift start v+                           in next : trajectoryToPath next vs --- | Squared euclidean distance between two unit vectors.-euclidDistSq :: X -> Vector -> Vector -> Int-euclidDistSq lxsize dir0 dir1-  | VectorXY (x0, y0) <- fromDir lxsize dir0-  , VectorXY (x1, y1) <- fromDir lxsize dir1 =-  euclidDistSqXY $ VectorXY (x1 - x0, y1 - y0)+-- | A vector from a point to another. We have+--+-- > shift pos1 (displacement pos1 pos2) == pos2+displacement :: Point -> Point -> Vector+{-# INLINE displacement #-}+displacement (Point x0 y0) (Point x1 y1) = Vector (x1 - x0) (y1 - y0) --- | Checks whether a unit vector is a diagonal direction,--- as opposed to cardinal. If the vector is not unit,--- it reject horizontal and vertical vectors.-diagonal :: X -> Vector -> Bool-diagonal lxsize dir | VectorXY (x, y) <- fromDir lxsize dir =-  x * y /= 0+-- | A list of vectors between a list of points.+pathToTrajectory :: [Point] -> [Vector]+pathToTrajectory [] = []+pathToTrajectory lp1@(_ : lp2) = zipWith displacement lp1 lp2 --- | Reverse an arbirary vector.-neg :: Vector -> Vector-neg (Vector dir) = Vector (-dir)+type RadianAngle = Double +-- | Rotate a vector by the given angle (expressed in radians)+-- counterclockwise and return a unit vector approximately in the resulting+-- direction.+rotate :: RadianAngle -> Vector -> Vector+rotate angle (Vector x' y') =+  let x = fromIntegral x'+      y = fromIntegral y'+      -- Minus before the angle comes from our coordinates being+      -- mirrored along the X axis (Y coordinates grow going downwards).+      dx = x * cos (-angle) - y * sin (-angle)+      dy = x * sin (-angle) + y * cos (-angle)+  in normalize dx dy+ -- TODO: use bla for that -- | Given a vector of arbitrary non-zero length, produce a unit vector -- that points in the same direction (in the chessboard metric). -- Of several equally good directions it picks one of those that visually -- (in the euclidean metric) maximally align with the original vector.-normalize :: X -> VectorXY -> Vector-normalize lxsize v@(VectorXY (dx, dy)) =+normalize :: Double -> Double -> Vector+normalize dx dy =   assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `twith` (dx, dy)) $   let angle :: Double-      angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2)+      angle = atan (dy / dx) / (pi / 2)       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` "impossible angle"-                               `twith` (lxsize, dx, dy, angle)-      rxy = if dx >= 0-            then VectorXY dxy-            else negXY $ VectorXY dxy-  in assert (not (isUnitXY v) || v == rxy+                               `twith` (dx, dy, angle)+  in if dx >= 0+     then uncurry Vector dxy+     else neg $ uncurry Vector dxy++normalizeVector :: Vector -> Vector+normalizeVector v@(Vector vx vy) =+  let res = normalize (fromIntegral vx) (fromIntegral vy)+  in assert (not (isUnit v) || v == res              `blame` "unit vector gets untrivially normalized"-             `twith` (v, rxy))-     $ toDir lxsize rxy+             `twith` (v, res))+     res  -- TODO: Perhaps produce all acceptable directions and let AI choose. -- That would also eliminate the Doubles. Or only directions from bla?@@ -137,28 +212,130 @@ -- (in the chessboard metric) it picks one of those that visually -- (in the euclidean metric) maximally align with the vector between -- the two points.-towards :: X -> Point -> Point -> Vector-towards lxsize pos0 pos1 =-  assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1)) $-  let v = displacementXYZ lxsize pos0 pos1-  in normalize lxsize v+towards :: Point -> Point -> Vector+towards pos0 pos1 =+  assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1))+  $ normalizeVector $ displacement pos0 pos1 --- | A vector from a point to another. We have------ > shift pos1 (displacement pos1 pos2) == pos2------ Particularly simple and fast implementation in the linear representation.-displacement :: Point -> Point -> Vector-displacement pos1 pos2 = Vector $ fromEnum pos2 - fromEnum pos1+newtype BfsDistance = BfsDistance Word8+  deriving (Show, Eq, Ord, Enum, Bounded, Bits) --- | A list of vectors between a list of points.-displacePath :: [Point] -> [Vector]-displacePath []  = []-displacePath lp1@(_ : lp2) = zipWith displacement lp1 lp2+data MoveLegal = MoveBlocked | MoveToOpen | MoveToUnknown+  deriving Eq --- | A list of points that a list of vectors leads to.-shiftPath :: Point -> [Vector] -> [Point]-shiftPath _     [] = []-shiftPath start (v : vs) =-  let next = shift start v-  in next : shiftPath next vs+minKnownBfs :: BfsDistance+minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2++apartBfs :: BfsDistance+apartBfs = pred minKnownBfs++-- TODO: Move somewhere; in particular, only clients need to know that.+fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is move from a known tile legal+        -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal+        -> Point                          -- ^ starting position+        -> PointArray.Array BfsDistance   -- ^ initial array, with @apartBfs@+        -> PointArray.Array BfsDistance   -- ^ array with calculated distances+fillBfs isEnterable passUnknown origin aInitial =+  -- TODO: copy, thaw, mutate, freeze+  let maxUnknownBfs = pred apartBfs+      maxKnownBfs = pred maxBound+      bfs :: Seq.Seq (Point, BfsDistance)+          -> PointArray.Array BfsDistance+          -> PointArray.Array BfsDistance+      bfs q a =+        case Seq.viewr q of+          Seq.EmptyR -> a  -- no more positions to check+          _ Seq.:> (_, d)+            | d == maxUnknownBfs || d == maxKnownBfs -> a  -- too far+          q1 Seq.:> (pos, oldDistance) | oldDistance >= minKnownBfs ->+            let distance = succ oldDistance+                allMvs = map (shift pos) moves+                freshMv p = a PointArray.! p == apartBfs+                freshMvs = filter freshMv allMvs+                legal p = (p, isEnterable pos p)+                legalities = map legal freshMvs+                notBlocked = filter ((/= MoveBlocked) . snd) legalities+                legalToDist l = if l == MoveToOpen+                                then distance+                                else distance .&. complement minKnownBfs+                mvs = map (second legalToDist) notBlocked+                q2 = foldr (Seq.<|) q1 mvs+                s2 = a PointArray.// mvs+            in bfs q2 s2+          q1 Seq.:> (pos, oldDistance) ->+            let distance = succ oldDistance+                allMvs = map (shift pos) moves+                goodMv p = a PointArray.! p == apartBfs && passUnknown pos p+                mvs = zip (filter goodMv allMvs) (repeat distance)+                q2 = foldr (Seq.<|) q1 mvs+                s2 = a PointArray.// mvs+            in bfs q2 s2+      origin0 = (origin, minKnownBfs)+  in bfs (Seq.singleton origin0) (aInitial PointArray.// [origin0])++-- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/+-- to determine a few really different paths and compare them,+-- e.g., how many closed doors they pass, open doors, unknown tiles+-- on the path or close enough to reveal them.+-- Also, check if JPS can somehow optimize BFS or pathBfs.+-- | Find a path, without the source position, with the smallest length.+-- The @eps@ coefficient determines which direction (or the closest+-- directions available) that path should prefer, where 0 means north-west+-- and 1 means north.+findPathBfs :: (Point -> Point -> MoveLegal)+            -> (Point -> Point -> Bool)+            -> Point -> Point -> Int -> PointArray.Array BfsDistance+            -> Maybe [Point]+findPathBfs isEnterable passUnknown source target sepsRaw bfs =+  assert (bfs PointArray.! source == minKnownBfs) $+  let targetDist = bfs PointArray.! target+  in if targetDist == apartBfs+     then Nothing+     else+       let eps = abs sepsRaw `mod` length moves+           mix (x : xs) ys = x : mix ys xs+           mix [] ys = ys+           preferedMoves = let (ch1, ch2) = splitAt eps moves+                               ch = ch2 ++ ch1+                           in mix ch (reverse ch)+           track :: Point -> BfsDistance -> [Point] -> [Point]+           track pos oldDist suffix | oldDist == minKnownBfs =+             assert (pos == source+                     `blame` (source, target, pos, suffix)) suffix+           track pos oldDist suffix | oldDist > minKnownBfs =+             let dist = pred oldDist+                 children = map (shift pos) preferedMoves+                 matchesDist p = bfs PointArray.! p == dist+                                 && isEnterable p pos == MoveToOpen+                 minP = fromMaybe (assert `failure` (pos, oldDist, children))+                                  (find matchesDist children)+             in track minP dist (pos : suffix)+           track pos oldDist suffix =+             let distUnknown = pred oldDist+                 distKnown = distUnknown .|. minKnownBfs+                 children = map (shift pos) preferedMoves+                 matchesDistUnknown p = bfs PointArray.! p == distUnknown+                                        && passUnknown p pos+                 matchesDistKnown p = bfs PointArray.! p == distKnown+                                      && isEnterable p pos == MoveToUnknown+                 (minP, dist) = case find matchesDistKnown children of+                   Just p -> (p, distKnown)+                   Nothing -> case find matchesDistUnknown children of+                     Just p -> (p, distUnknown)+                     Nothing -> assert `failure` (pos, oldDist, children)+             in track minP dist (pos : suffix)+       in Just $ track target targetDist []++accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int+{-# INLINE accessBfs #-}+accessBfs bfs target =+  let dist = bfs PointArray.! target+  in if dist == apartBfs+     then Nothing+     else Just $ fromEnum $ dist .&. complement minKnownBfs++posAimsPos :: PointArray.Array BfsDistance -> Point -> Point -> Bool+{-# INLINE posAimsPos #-}+posAimsPos bfs bpos target =+  let mdist = accessBfs bfs target+  in mdist == Just (chessDist bpos target)
− Game/LambdaHack/Common/VectorXY.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Basic cartesian geometry operations on 2D vectors.-module Game.LambdaHack.Common.VectorXY-  ( VectorXY(..), shiftXY, movesXY, movesCardinalXY-  , chessDistXY, euclidDistSqXY, negXY, vicinityXY, vicinityCardinalXY-  ) where--import Data.Binary--import Game.LambdaHack.Common.PointXY---- | 2D vectors in cartesian representation.-newtype VectorXY = VectorXY (X, Y)-  deriving (Eq, Ord, Show, Read, Binary)---- | Shift a point by a vector.-shiftXY :: PointXY -> VectorXY -> PointXY-shiftXY (PointXY (x0, y0)) (VectorXY (x1, y1)) = PointXY (x0 + x1, y0 + y1)---- | Vectors of all unit moves in the chessboard metric,--- clockwise, starting north-west.-movesXY :: [VectorXY]-movesXY =-  map VectorXY-    [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]---- | Vectors of all cardinal direction unit moves, clockwise, starting north.-movesCardinalXY :: [VectorXY]-movesCardinalXY = map VectorXY [(0, -1), (1, 0), (0, 1), (-1, 0)]---- | The lenght of a vector in the chessboard metric,--- where diagonal moves cost 1.-chessDistXY :: VectorXY -> Int-chessDistXY (VectorXY (x, y)) = max (abs x) (abs y)---- | Squared euclidean length of a vector.-euclidDistSqXY :: VectorXY -> Int-euclidDistSqXY (VectorXY (x, y)) = x * x + y * y---- | Reverse an arbirary vector.-negXY :: VectorXY -> VectorXY-negXY (VectorXY (x, y)) = VectorXY (-x, -y)---- | All (8 at most) closest neighbours of a point within an area.-vicinityXY :: (X, Y, X, Y)  -- ^ limit the search to this area-           -> PointXY       -- ^ position to find neighbours of-           -> [PointXY]-vicinityXY area xy =-  [ res | dxy <- movesXY, let res = shiftXY xy dxy, insideXY res area ]---- | All (4 at most) cardinal direction neighbours of a point within an area.-vicinityCardinalXY :: (X, Y, X, Y)  -- ^ limit the search to this area-                   -> PointXY       -- ^ position to find neighbours of-                   -> [PointXY]-vicinityCardinalXY area xy =-  [ res-  | dxy <- movesCardinalXY, let res = shiftXY xy dxy, insideXY res area ]
Game/LambdaHack/Content/ActorKind.hs view
@@ -1,12 +1,13 @@ -- | The type of kinds of monsters and heroes. module Game.LambdaHack.Content.ActorKind-  ( ActorKind(..), avalidate+  ( ActorKind(..), validateActorKind   ) where  import Control.Arrow ((&&&)) import Data.List import qualified Data.Ord as Ord import Data.Text (Text)+import qualified Data.Text as T  import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color@@ -35,10 +36,12 @@ -- | Filter a list of kinds, passing through only the incorrect ones, if any. -- -- Make sure actor kinds can be told apart on the level map.-avalidate :: [ActorKind] -> [ActorKind]-avalidate l =+validateActorKind :: [ActorKind] -> [ActorKind]+validateActorKind l =   let cmp = Ord.comparing $ asymbol &&& acolor       eq ka1 ka2 = cmp ka1 ka2 == Ord.EQ       sorted = sortBy cmp l       nubbed = nubBy eq sorted-  in deleteFirstsBy eq sorted nubbed+      tooSimilar = deleteFirstsBy eq sorted nubbed+      tooVerbose = filter (\ak -> T.length (aname ak) > 25) l+  in tooSimilar ++ tooVerbose
Game/LambdaHack/Content/CaveKind.hs view
@@ -1,14 +1,13 @@ -- | The type of cave layout kinds. module Game.LambdaHack.Content.CaveKind-  ( CaveKind(..), cvalidate+  ( CaveKind(..), validateCaveKind   ) where -import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T  import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.PointXY+import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random  -- | Parameters for the generation of dungeon levels.@@ -33,10 +32,11 @@   , citemFreq       :: ![(Int, Text)]  -- ^ item groups to consider   , cdefTile        :: !Text        -- ^ the default cave tile group name   , cdarkCorTile    :: !Text        -- ^ the dark cave corridor tile group name-  , clitCorTile     :: !Text        -- ^ the dark cave corridor tile group name+  , clitCorTile     :: !Text        -- ^ the lit 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+  , couterFenceTile :: !Text        -- ^ the outer fence wall group name+  , clegendDarkTile :: !Text        -- ^ the dark place plan legend group name+  , clegendLitTile  :: !Text        -- ^ the lit place plan legend group name   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53 @@ -45,18 +45,21 @@ -- -- Catch caves with not enough space for all the places. Check the size -- of the cave descriptions to make sure they fit on screen.-cvalidate :: [CaveKind] -> [CaveKind]-cvalidate = L.filter (\ CaveKind{ cgrid-                                , cminPlaceSize-                                , cmaxPlaceSize-                                , ..-                                } ->+validateCaveKind :: [CaveKind] -> [CaveKind]+validateCaveKind = filter (\ CaveKind{..} ->   let (maxGridX, maxGridY) = maxDiceXY cgrid       (minMinSizeX, minMinSizeY) = minDiceXY cminPlaceSize       (maxMinSizeX, maxMinSizeY) = maxDiceXY cminPlaceSize       (minMaxSizeX, minMaxSizeY) = minDiceXY cmaxPlaceSize-      xborder = if maxGridX == 1 then 3 else 1-      yborder = if maxGridX == 1 then 3 else 1+      -- If there is at most one room, we need extra borders for a passage,+      -- but if there may be more rooms, we have that space, anyway,+      -- because multiple rooms take more space than borders.+      xborder = if maxGridX == 1 || couterFenceTile /= "basic outer fence"+                then 2+                else 0+      yborder = if maxGridY == 1 || couterFenceTile /= "basic outer fence"+                then 2+                else 0   in T.length cname > 25      || cxsize < 7      || cysize < 7@@ -64,5 +67,5 @@      || minMinSizeY < 1      || minMaxSizeX < maxMinSizeX      || minMaxSizeY < maxMinSizeY-     || maxGridX * (maxMinSizeX + xborder) >= cxsize-     || maxGridY * (maxMinSizeY + yborder) >= cysize)+     || maxGridX * (maxMinSizeX + 1) + xborder >= cxsize+     || maxGridY * (maxMinSizeY + 1) + yborder >= cysize)
Game/LambdaHack/Content/FactionKind.hs view
@@ -1,6 +1,6 @@ -- | The type of kinds of game factions (heroes, enemies, NPCs, etc.). module Game.LambdaHack.Content.FactionKind-  ( FactionKind(..), fvalidate+  ( FactionKind(..), validateFactionKind   ) where  import Data.Text (Text)@@ -12,12 +12,12 @@   { fsymbol        :: !Char       -- ^ a symbol   , fname          :: !Text       -- ^ short description   , ffreq          :: !Freqs      -- ^ frequency within groups-  , fAbilityLeader :: ![Ability]  -- ^ abilities of the selected actor+  , fAbilityLeader :: ![Ability]  -- ^ abilities of the picked leader   , fAbilityOther  :: ![Ability]  -- ^ abilities of the other actors   }   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.-fvalidate :: [FactionKind] -> [FactionKind]-fvalidate _ = []+validateFactionKind :: [FactionKind] -> [FactionKind]+validateFactionKind _ = []
Game/LambdaHack/Content/ItemKind.hs view
@@ -1,32 +1,33 @@ -- | The type of kinds of weapons and treasure. module Game.LambdaHack.Content.ItemKind-  ( ItemKind(..), ivalidate+  ( ItemKind(..), validateItemKind   ) where  import Data.Text (Text)+import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Flavour+import qualified Game.LambdaHack.Common.ItemFeature as IF import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Random  -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind-  { isymbol      :: !Char         -- ^ map symbol-  , iname        :: !Text         -- ^ generic name-  , ifreq        :: !Freqs        -- ^ frequency within groups-  , iflavour     :: ![Flavour]    -- ^ possible flavours-  , ieffect      :: !(Effect RollDeep)  -- ^ the effect when activated-  , icount       :: !RollDeep     -- ^ created in that quantify-  , iverbApply   :: !MU.Part      -- ^ the verb for applying and combat-  , iverbProject :: !MU.Part      -- ^ the verb for projecting-  , iweight      :: !Int          -- ^ weight in grams-  , itoThrow     :: !Int          -- ^ percentage bonus or malus to throw speed+  { isymbol      :: !Char          -- ^ map symbol+  , iname        :: !Text          -- ^ generic name+  , ifreq        :: !Freqs         -- ^ frequency within groups+  , iflavour     :: ![Flavour]     -- ^ possible flavours+  , icount       :: !RollDeep      -- ^ created in that quantify+  , iverbApply   :: !MU.Part       -- ^ the verb for applying and combat+  , iverbProject :: !MU.Part       -- ^ the verb for projecting+  , iweight      :: !Int           -- ^ weight in grams+  , itoThrow     :: !Int           -- ^ percentage bonus to throw speed+  , ifeature     :: ![IF.Feature]  -- ^ properties   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53  -- | No specific possible problems for the content of this kind, so far, -- so the validation function always returns the empty list of offending kinds.-ivalidate :: [ItemKind] -> [ItemKind]-ivalidate _ = []+validateItemKind :: [ItemKind] -> [ItemKind]+validateItemKind l = filter (\ik -> T.length (iname ik) > 25) l
Game/LambdaHack/Content/ModeKind.hs view
@@ -1,12 +1,12 @@ -- | The type of kinds of game modes. module Game.LambdaHack.Content.ModeKind-  ( Caves, Players(..), Player(..), ModeKind(..), mvalidate+  ( Caves, Players(..), Player(..), ModeKind(..), validateModeKind   ) where  import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Text (Text)-import NLP.Miniutter.English ()+import qualified NLP.Miniutter.English as MU ()  import Game.LambdaHack.Common.Misc (Freqs, LevelId) @@ -39,6 +39,7 @@ data Player = Player   { playerName     :: !Text     -- ^ name of the player   , playerFaction  :: !Text     -- ^ name of faction(s) the player can control+  , playerSpawn    :: !Int      -- ^ spawning frequency   , playerEntry    :: !LevelId  -- ^ level where the initial members start   , playerInitial  :: !Int      -- ^ number of initial members   , playerAiLeader :: !Bool     -- ^ is the leader under AI control?@@ -50,17 +51,19 @@   }   deriving (Show, Eq) +-- TODO: assert every Player's playerName's first word's length <= 15 -- 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 _ = []+validateModeKind :: [ModeKind] -> [ModeKind]+validateModeKind _ = []  instance Binary Player where   put Player{..} = do     put playerName     put playerFaction+    put playerSpawn     put playerEntry     put playerInitial     put playerAiLeader@@ -70,10 +73,11 @@   get = do     playerName <- get     playerFaction <- get+    playerSpawn <- get     playerEntry <- get     playerInitial <- get     playerAiLeader <- get     playerAiOther <- get     playerHuman <- get     playerUI <- get-    return Player{..}+    return $! Player{..}
Game/LambdaHack/Content/PlaceKind.hs view
@@ -1,9 +1,8 @@ -- | The type of kinds of rooms, halls and passages. module Game.LambdaHack.Content.PlaceKind-  ( PlaceKind(..), Cover(..), Fence(..), pvalidate+  ( PlaceKind(..), Cover(..), Fence(..), validatePlaceKind   ) where -import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T @@ -43,9 +42,9 @@ -- | Filter a list of kinds, passing through only the incorrect ones, if any. -- -- Verify that the top-left corner map is rectangular and not empty.-pvalidate :: [PlaceKind] -> [PlaceKind]-pvalidate = L.filter (\ PlaceKind{..} ->+validatePlaceKind :: [PlaceKind] -> [PlaceKind]+validatePlaceKind = filter (\ PlaceKind{..} ->   let dxcorner = case ptopLeft of         [] -> 0         l : _ -> T.length l-  in dxcorner /= 0 && L.any (/= dxcorner) (L.map T.length ptopLeft))+  in dxcorner /= 0 && any (/= dxcorner) (map T.length ptopLeft))
Game/LambdaHack/Content/RuleKind.hs view
@@ -1,17 +1,21 @@ -- | The type of game rule sets and assorted game data. module Game.LambdaHack.Content.RuleKind-  ( RuleKind(..), ruvalidate+  ( RuleKind(..), validateRuleKind, FovMode(..)   ) where +import Data.Binary import Data.Text (Text) import Data.Version +import Game.LambdaHack.Common.HumanCmd+import qualified Game.LambdaHack.Common.Key as K 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.+-- TODO: in the future, in @raccessible@ check flying for chasms,+-- swimming for water, etc.+-- TODO: tweak other code to allow games with only cardinal direction moves  -- | The type of game rule sets and assorted game data. --@@ -23,25 +27,64 @@ -- and then @RuleKind@ will become just a starting template, analogously -- as for the other content. ----- The @raccessible@ field holds a predicate that tells--- whether one position is accessible from another.+-- The @raccessible@ field hold extra conditions that have to be met+-- for a tile to be accessible, on top of being an open tile+-- (or openable, in some contexts). The @raccessibleDoor@ field+-- contains yet additional conditions concerning tiles that are doors,+-- whether open or closed. -- Precondition: the two positions are next to each other.+-- We assume the predicate is symmetric. data RuleKind = RuleKind-  { 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-  , rpathsDataFile   :: FilePath -> IO FilePath  -- ^ the path to data files-  , 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+  { rsymbol         :: !Char      -- ^ a symbol+  , rname           :: !Text      -- ^ short description+  , rfreq           :: !Freqs     -- ^ frequency within groups+  , raccessible     :: !(Maybe (Point -> Point -> Bool))+  , raccessibleDoor :: !(Maybe (Point -> Point -> Bool))+  , 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+  , ritemRanged     :: ![Char]    -- ^ ranged weapons and missiles+  , ritemProject    :: ![Char]    -- ^ symbols of items AI can project+  , rcfgUIName      :: !FilePath  -- ^ base name of the UI config file+  , rcfgUIDefault   :: !String    -- ^ the default UI settings config file+  , rmainMenuArt    :: !Text      -- ^ the ASCII art for the Main Menu+  , rhumanCommands  :: ![(K.KM, (CmdCategory, HumanCmd))]+                                  -- ^ default client commands+  , rfirstDeathEnds :: !Bool      -- ^ whether first non-spawner actor death+                                  --   ends the game+  , rfovMode        :: !FovMode   -- ^ FOV calculation mode+  , rsaveBkpClips   :: !Int       -- ^ game backup is saved that often+  , rleadLevelClips :: !Int       -- ^ AI/spawn leader level flipped that often+  , rscoresFile     :: !FilePath  -- ^ name of the scores file+  , rsavePrefix     :: !String    -- ^ name of the savefile prefix   } +-- TODO: should Blind really be a FovMode, or a modifier? Let's decide+-- 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+  deriving (Show, Read)++instance Binary FovMode where+  put Shadow      = putWord8 0+  put Permissive  = putWord8 1+  put (Digital r) = putWord8 2 >> put r+  put Blind       = putWord8 3+  get = do+    tag <- getWord8+    case tag of+      0 -> return Shadow+      1 -> return Permissive+      2 -> fmap Digital get+      3 -> return Blind+      _ -> fail "no parse (FovMode)"+ -- | A dummy instance of the 'Show' class, to satisfy general requirments -- about content. We won't have many rule sets and they contain functions, -- so defining a proper instance is not practical.@@ -49,5 +92,5 @@   show _ = "The game ruleset specification."  -- | Validates the ASCII art format (TODO).-ruvalidate :: [RuleKind] -> [RuleKind]-ruvalidate _ = []+validateRuleKind :: [RuleKind] -> [RuleKind]+validateRuleKind _ = []
Game/LambdaHack/Content/TileKind.hs view
@@ -1,27 +1,28 @@ -- | The type of kinds of terrain tiles. module Game.LambdaHack.Content.TileKind-  ( TileKind(..), tvalidate+  ( TileKind(..), validateTileKind, actionFeatures   ) where -import qualified Data.List as L+import Control.Exception.Assert.Sugar import qualified Data.Map.Strict as M+import Data.Maybe+import qualified Data.Set as S import Data.Text (Text)  import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Feature+import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Misc-import Control.Exception.Assert.Sugar  -- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation -- of the absence of a corresponding type @Tile@ that would hold -- particular concrete tiles in the dungeon. data TileKind = TileKind-  { tsymbol  :: !Char       -- ^ map symbol-  , tname    :: !Text       -- ^ short description-  , tfreq    :: !Freqs      -- ^ frequency within groups-  , tcolor   :: !Color      -- ^ map color-  , tcolor2  :: !Color      -- ^ map color when not in FOV-  , tfeature :: ![Feature]  -- ^ properties+  { tsymbol  :: !Char         -- ^ map symbol+  , tname    :: !Text         -- ^ short description+  , tfreq    :: !Freqs        -- ^ frequency within groups+  , tcolor   :: !Color        -- ^ map color+  , tcolor2  :: !Color        -- ^ map color when not in FOV+  , tfeature :: ![F.Feature]  -- ^ properties   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53 @@ -30,25 +31,52 @@ -- 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.--- Otherwise, the player has to inspect manually all the tiles of that kind--- to see if any is special. This is a part of a stronger--- but less precise property that tiles that look the same can't be--- distinguished by player actions (but may behave differently--- wrt dungeon generation, AI preferences, etc.).-tvalidate :: [TileKind] -> [TileKind]-tvalidate lt =-  let listFov f = L.map (\ kt -> ( ( tsymbol kt-                                   , Suspect `elem` tfeature kt-                                   , f kt-                                   )-                                 , [kt] )) lt+-- If tiles look the same on the map, the description and the substantial+-- features should be the same, too. Otherwise, the player has to inspect+-- manually all the tiles of that kind, or even experiment with them,+-- to see if any is special. This would be tedious. Note that iiles may freely+-- differ wrt dungeon generation, AI preferences, etc.+validateTileKind :: [TileKind] -> [TileKind]+validateTileKind lt =+  let listFov f = map (\kt -> ( ( tsymbol kt+                                  , F.Suspect `elem` tfeature kt+                                  , f kt+                                  )+                                , [kt] )) lt       mapFov :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind]       mapFov f = M.fromListWith (++) $ listFov f       namesUnequal [] = assert `failure` "no TileKind content" `twith` 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+      namesUnequal (hd : tl) =+        -- Catch if at least one is different.+        any (/= tname hd) (map tname tl)+        || any (/= actionFeatures True hd) (map (actionFeatures True) tl)+      confusions f = filter namesUnequal $ M.elems $ mapFov f   in case confusions tcolor ++ confusions tcolor2 of     [] -> []     l : _ -> l++-- | Features of tiles that differentiate them substantially from one another.+-- By tile contents validation condition, this means the player+-- can tell such tile apart, and only looking at the map, not tile name.+-- So if running uses this function, it won't stop at places that the player+-- can't himself tell from other places, and so running does not confer+-- any advantages, except UI convenience.+actionFeatures :: Bool -> TileKind -> S.Set F.Feature+actionFeatures markSuspect t =+  let f feat = case feat of+        F.Cause{} -> Just feat+        F.OpenTo{} -> Just $ F.OpenTo ""  -- if needed, remove prefix/suffix+        F.CloseTo{} -> Just $ F.CloseTo ""+        F.ChangeTo{} -> Just $ F.ChangeTo ""+        F.Walkable -> Just feat+        F.Clear -> Just feat+        F.Suspect -> if markSuspect then Just feat else Nothing+        F.Aura{} -> Just feat+        F.Impenetrable -> Just feat+        F.Trail -> Just feat  -- doesn't affect tile behaviour, but important+        F.HideAs{} -> Nothing+        F.RevealAs{} -> Nothing+        F.Dark -> Nothing  -- not important any longer, after FOV computed+        F.CanItem -> Nothing+        F.CanActor -> Nothing+  in S.fromList $ mapMaybe f $ tfeature t
Game/LambdaHack/Frontend.hs view
@@ -12,6 +12,7 @@ import Control.Concurrent import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, writeTQueue) import qualified Control.Concurrent.STM as STM+import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.Maybe@@ -21,7 +22,6 @@ import System.IO import System.IO.Unsafe (unsafePerformIO) -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Key as K@@ -59,7 +59,9 @@  startupF :: DebugModeCli -> IO () -> IO () startupF dbg cont =-  (if sfrontendStd dbg then stdStartup else chosenStartup) dbg $ \fs -> do+  (if sfrontendNo dbg then noStartup+   else if sfrontendStd dbg then stdStartup+        else chosenStartup) dbg $ \fs -> do     let debugPrint t = when (sdbgMsgCli dbg) $ do           T.hPutStrLn stderr t           hFlush stderr@@ -80,7 +82,7 @@ promptGetKey fs keys@(firstKM:_) frame = do   km <- fpromptGetKey fs frame   if km `elem` keys-    then return km+    then return $! km     else do       let DebugModeCli{snoMore} = fdebugCli fs       if snoMore then return firstKM@@ -92,7 +94,7 @@ connMulti = unsafePerformIO $ do   fromMulti <- newMVar undefined   toMulti <- newTQueueIO-  return ConnMulti{..}+  return $! ConnMulti{..}  -- | Augment a function that takes and returns keys. getConfirmGeneric :: Monad m@@ -109,7 +111,7 @@   let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap       reqMap2 = EM.delete fid reqMap   mapM_ (displayAc fs) queue-  return reqMap2+  return $! reqMap2  displayAc :: Frontend -> AcFrame -> IO () displayAc fs (AcConfirm fr) = void $ getConfirmGeneric (promptGetKey fs) [] fr@@ -133,12 +135,12 @@   let topRight = True       lxsize = xsizeSingleFrame frame       lysize = ysizeSingleFrame frame-      msg = "Player" <+> showT (fromEnum side) <> ","+      msg = "Player" <+> tshow (fromEnum side) <> ","             <+> pname <> (if T.null pname then "" else ",")             <+> "get ready!"   animMap <- rndToIO $ fadeout out topRight lxsize lysize-  let sfTop = truncateMsg lxsize msg-      basicFrame = frame {sfTop}+  let sfTop = truncateToOverlay lxsize msg+      basicFrame = frame {sfTop}  -- overwrite the whole original overlay       animFrs = renderAnim lxsize lysize basicFrame animMap       frs | out = animFrs             -- Empty frame to mark the fade-in end,@@ -182,7 +184,7 @@           let singles = toSingles oldFid reqMap  -- not @reqMap2@!               lastFrame = fromMaybe oldFrame $ listToMaybe $ reverse singles           fadeF fs True fid pname lastFrame-          return reqMap2+          return $! reqMap2       let singles = toSingles fid reqMap2           firstFrame = fromMaybe frontFr $ listToMaybe singles       -- TODO: @nU@ is unreliable, when some of UI players die;
Game/LambdaHack/Frontend/Chosen.hs view
@@ -2,7 +2,7 @@ -- | Re-export the operations of the chosen raw frontend -- (determined at compile time with cabal flags). module Game.LambdaHack.Frontend.Chosen-  ( Frontend(..), chosenStartup, stdStartup+  ( Frontend(..), chosenStartup, stdStartup, noStartup   , frontendName   ) where @@ -44,5 +44,13 @@     cont $ Frontend       { fdisplay = Std.fdisplay fs       , fpromptGetKey = Std.fpromptGetKey fs+      , fdebugCli+      }++noStartup :: DebugModeCli -> (Frontend -> IO ()) -> IO ()+noStartup fdebugCli cont =+    cont $ Frontend+      { fdisplay = \_ _ -> return ()+      , fpromptGetKey = \_ -> return K.escKey       , fdebugCli       }
Game/LambdaHack/Frontend/Curses.hs view
@@ -1,4 +1,6 @@--- | Text frontend based on HSCurses.+-- | Text frontend based on HSCurses. This frontend is not fully supported+-- due to the limitations of the curses library (keys, colours, last character+-- of the last line). module Game.LambdaHack.Frontend.Curses   ( -- * Session data type for the frontend     FrontendSession@@ -8,16 +10,15 @@   , frontendName, startup   ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Char (chr, ord)-import qualified Data.List as L import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified UI.HSCurses.Curses as C import qualified UI.HSCurses.CursesHelper as C -import Control.Exception.Assert.Sugar-import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..))+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Msg@@ -45,7 +46,7 @@             -- No more color combinations possible: 16*4, 64 is max.             bg <- Color.legalBG ]   nr <- C.colorPairs-  when (nr < L.length s) $+  when (nr < length s) $     C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr)   let (ks, vs) = unzip s   ws <- C.convertStyles vs@@ -60,18 +61,19 @@          -> Maybe SingleFrame  -- ^ the screen frame to draw          -> IO () fdisplay _ _ Nothing = return ()-fdisplay FrontendSession{..}  _ (Just SingleFrame{..}) = do+fdisplay FrontendSession{..}  _ (Just rawSF) = do+  let SingleFrame{sfLevel} = overlayOverlay rawSF   -- let defaultStyle = C.defaultCursesStyle   -- Terminals with white background require this:   let defaultStyle = sstyles M.! Color.defAttr   C.erase   C.setStyle defaultStyle-  C.mvWAddStr swin 0 0 (T.unpack sfTop)   -- We need to remove the last character from the status line,   -- because otherwise it would overflow a standard size xterm window,   -- due to the curses historical limitations.-  C.mvWAddStr swin (L.length sfLevel + 1) 0 (L.init $ T.unpack sfBottom)-  let nm = L.zip [0..] $ L.map (L.zip [0..]) sfLevel+  let sfLevelDecoded = map decodeLine sfLevel+      level = init sfLevelDecoded ++ [init $ last sfLevelDecoded]+      nm = zip [0..] $ map (zip [0..]) level   sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles)               >> C.mvWAddStr swin (y + 1) x [acChar]             | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ]@@ -100,6 +102,7 @@     C.KeyChar ' '    -> (K.Space,   K.NoModifier)     C.KeyChar '\t'   -> (K.Tab,     K.NoModifier)     C.KeyBTab        -> (K.BackTab, K.NoModifier)+    C.KeyBackspace   -> (K.BackSpace, K.NoModifier)     C.KeyUp          -> (K.Up,      K.NoModifier)     C.KeyDown        -> (K.Down,    K.NoModifier)     C.KeyLeft        -> (K.Left,    K.NoModifier)@@ -107,8 +110,8 @@     C.KeyRight       -> (K.Right,   K.NoModifier)     C.KeySRight      -> (K.Right,   K.NoModifier)     C.KeyHome        -> (K.Home,    K.NoModifier)-    C.KeyPPage       -> (K.PgUp,    K.NoModifier)     C.KeyEnd         -> (K.End,     K.NoModifier)+    C.KeyPPage       -> (K.PgUp,    K.NoModifier)     C.KeyNPage       -> (K.PgDn,    K.NoModifier)     C.KeyBeg         -> (K.Begin,   K.NoModifier)     C.KeyB2          -> (K.Begin,   K.NoModifier)@@ -122,12 +125,12 @@       | 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,+        -- Movement keys are more important than leader picking,         -- 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)-    _                       -> (K.Unknown (showT e),  K.NoModifier)+    _                       -> (K.Unknown (tshow e), K.NoModifier)  toFColor :: Color.Color -> C.ForegroundColor toFColor Color.Black     = C.BlackF
Game/LambdaHack/Frontend/Gtk.hs view
@@ -10,6 +10,7 @@   ) where  import Control.Concurrent+import Control.Exception.Assert.Sugar import Control.Monad import Control.Monad.Reader import qualified Data.ByteString.Char8 as BS@@ -17,13 +18,10 @@ import Data.List import qualified Data.Map.Strict as M import Data.Maybe-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8) import Graphics.UI.Gtk hiding (Point) import System.Time -import Control.Exception.Assert.Sugar-import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..))+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Utils.LQueue@@ -75,13 +73,6 @@     _ ->       putMVar sframeState fs -lengthQueue :: FrontendSession -> IO Int-lengthQueue FrontendSession{sframeState} = do-  fs <- readMVar sframeState-  case fs of-    FPushed{..} -> return $ lengthLQueue fpushed-    _ -> return 0- -- | The name of the frontend. frontendName :: String frontendName = "gtk"@@ -135,20 +126,9 @@     let !key = K.keyTranslate n         !modifier = modifierTranslate mods     liftIO $ do-      unless (deadKey n) $ do-        len <- lengthQueue sess-        if n == "space" && len > 1 then-          -- Only drop frames up to the first empty frame.-          -- Some new frames may be arriving at the same time-          -- or being displayed and removed, but we don't care.-          onQueue dropStartLQueue sess-        else-          -- Store the key in the channel. All but last frame will be dropped-          -- as soon as the channel is read. Use SPACE repeatedly to step-          -- through some intermediate frames of an animation --- other keys-          -- are not meant to be pressed many times before the engine-          -- is ready to recognize and process them.-          writeChan schanKey K.KM {key, modifier}+      unless (deadKey n) $+        -- Store the key in the channel.+        writeChan schanKey K.KM{key, modifier}       return True   -- Set the font specified in config, if any.   f <- fontDescriptionFromString $ fromMaybe "" sfont@@ -202,7 +182,7 @@ setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO () setTo _  _   _  (_,  [])         = return () setTo tb defAttr lx (ly, attr:attrs) = do-  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx+  ib <- textBufferGetIterAtLineOffset tb ly lx   ie <- textIterCopy ib   let setIter :: TextTag -> Int -> [TextTag] -> IO ()       setIter previous repetitions [] = do@@ -250,8 +230,8 @@   -- Check if the time is up.   let maxFps = fromMaybe defaultMaxFps smaxFps   curTime <- getClockTime-  let diffT = diffTime setTime curTime-  if diffT > microInSec `div` maxPolls maxFps+  let diffSetCur = diffTime setTime curTime+  if diffSetCur > microInSec `div` maxPolls maxFps     then do       -- Delay half of the time difference.       threadDelay $ diffTime curTime setTime `div` 2@@ -344,12 +324,13 @@     Just f  -> putMVar slastFull (f, noDelay)  evalFrame :: FrontendSession -> SingleFrame -> GtkFrame-evalFrame FrontendSession{stags} SingleFrame{..} =-  let levelChar = map (T.pack . map Color.acChar) sfLevel-      gfChar = encodeUtf8 $ T.intercalate (T.singleton '\n')-               $ sfTop : levelChar ++ [sfBottom]-      -- Strict version of @map (map ((stags M.!) . fst)) sfLevel@.-      gfAttr  = reverse $ foldl' ff [] sfLevel+evalFrame FrontendSession{stags} rawSF =+  let SingleFrame{sfLevel} = overlayOverlay rawSF+      sfLevelDecoded = map decodeLine sfLevel+      levelChar = unlines $ map (map Color.acChar) sfLevelDecoded+      gfChar = BS.pack $ init levelChar+      -- Strict version of @map (map ((stags M.!) . fst)) sfLevelDecoded@.+      gfAttr  = reverse $ foldl' ff [] sfLevelDecoded       ff ll l = reverse (foldl' f [] l) : ll       f l ac  = let !tag = stags M.! Color.acAttr ac in tag : l   in GtkFrame{..}@@ -411,22 +392,31 @@       return ()  -- | Display a prompt, wait for any key.--- Starts in Push mode, ends in None mode.+-- Starts in Push mode, ends in Push or 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   if snoMore then do-    -- Show all frames synchronously.+    -- Show all frames synchronously. Keys completely ignored. TODO: K.Space     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+    case km of+      K.KM{key=K.Space, modifier=K.NoModifier} ->+        -- Drop frames up to the first empty frame.+        -- Keep the last non-empty frame, if any.+        -- Pressing SPACE repeatedly can be used to step+        -- through intermediate stages of an animation,+        -- whereas any other key skips the whole animation outright.+        onQueue dropStartLQueue sess+      _ ->+        -- Show the last non-empty frame and empty the queue.+        trimFrameState sess     return km  -- | Tells a dead key.
Game/LambdaHack/Frontend/Std.hs view
@@ -10,11 +10,9 @@  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 (DebugModeCli (..), SingleFrame (..))+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K @@ -37,9 +35,9 @@          -> 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]+fdisplay _ _ (Just rawSF) =+  let SingleFrame{sfLevel} = overlayOverlay rawSF+      bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty]   in mapM_ BS.putStrLn bs  -- | Input key via the frontend.@@ -70,7 +68,7 @@     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,+        -- Movement keys are more important than leader picking,         -- so disabling the latter and interpreting the keypad numbers         -- as movement:       | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)
Game/LambdaHack/Frontend/Vty.hs view
@@ -8,12 +8,10 @@   , frontendName, startup   ) where -import qualified Data.List as L-import Data.Text.Encoding (encodeUtf8) import Graphics.Vty import qualified Graphics.Vty as Vty -import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..))+import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Msg@@ -42,16 +40,14 @@          -> 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{..} ->+fdisplay FrontendSession{svty} _ (Just rawSF) =+  let SingleFrame{sfLevel} = overlayOverlay rawSF+      img = (foldr (<->) empty_image+             . map (foldr (<|>) empty_image+                      . map (\ Color.AttrChar{..} ->                                 char (setAttr acAttr) acChar)))-            sfLevel-      pic = pic_for_image $-              utf8_bytestring (setAttr Color.defAttr) (encodeUtf8 sfTop)-              <-> img <->-              utf8_bytestring (setAttr Color.defAttr) (encodeUtf8 sfBottom)+            $ map decodeLine sfLevel+      pic = pic_for_image img   in update svty pic  -- | Input key via the frontend.@@ -64,7 +60,7 @@       EvKey n mods -> do         let key = keyTranslate n             modifier = modifierTranslate mods-        return K.KM {key, modifier}+        return $! K.KM {key, modifier}       _ -> nextEvent sess  -- | Display a prompt, wait for any key.@@ -73,6 +69,9 @@   fdisplay sess True $ Just frame   nextEvent sess +-- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals+-- so we should probably go back to using 0-9 (and Shift) for movement+-- but let's wait until vty 5.0 is out and see if it helps. keyTranslate :: Key -> K.Key keyTranslate n =   case n of@@ -81,23 +80,26 @@     (KASCII ' ')  -> K.Space     (KASCII '\t') -> K.Tab     KBackTab      -> K.BackTab+    KBS           -> K.BackSpace     KUp           -> K.Up     KDown         -> K.Down     KLeft         -> K.Left     KRight        -> K.Right     KHome         -> K.Home-    KPageUp       -> K.PgUp     KEnd          -> K.End+    KPageUp       -> K.PgUp     KPageDown     -> K.PgDn     KBegin        -> K.Begin+    KNP5          -> K.Begin     (KASCII c)    -> K.Char c-    _             -> K.Unknown (showT n)+    _             -> K.Unknown (tshow n)  -- | Translates modifiers to our own encoding. modifierTranslate :: [Modifier] -> K.Modifier modifierTranslate mods =   if MCtrl `elem` mods then K.Control else K.NoModifier +-- TODO: with vty 5.0 check if bold is still needed. -- A hack to get bright colors via the bold attribute. Depending on terminal -- settings this is needed or not and the characters really get bold or not. -- HSCurses does this by default, but in Vty you have to request the hack.
Game/LambdaHack/Server.hs view
@@ -16,9 +16,9 @@ import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.ServerCmd+import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Frontend import Game.LambdaHack.Server.Action-import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.LoopAction import Game.LambdaHack.Server.ServerSem import Game.LambdaHack.Server.State@@ -28,49 +28,54 @@ -- indicates if the command took some time. cmdSerSem :: (MonadAtomic m, MonadServer m) => CmdSer -> m Bool cmdSerSem cmd = case cmd of-  TakeTimeSer cmd2 -> cmdSerSemTakeTime cmd2 >> return True-  GameRestartSer aid t -> gameRestartSer aid t >> return False-  GameExitSer aid -> gameExitSer aid >> return False+  CmdTakeTimeSer cmd2 -> cmdSerSemTakeTime cmd2 >> return True+  GameRestartSer aid t d names -> gameRestartSer aid t d names >> return False+  GameExitSer aid d -> gameExitSer aid d >> return False   GameSaveSer _ -> gameSaveSer >> return False -cmdSerSemTakeTime :: (MonadAtomic m, MonadServer m) => CmdSerTakeTime -> m ()+cmdSerSemTakeTime :: (MonadAtomic m, MonadServer m) => CmdTakeTimeSer -> 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+  PickupSer aid i k -> pickupSer aid i k+  DropSer aid iid k -> dropSer aid iid k   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+  SetTrajectorySer aid -> setTrajectorySer aid  debugArgs :: IO DebugModeSer debugArgs = do   args <- getArgs   let usage =         [ "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"-        , "  --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"-        , "  --dumpConfig dump server config at the start of the game"-        , "  --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"+        , "  --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"+        , "  --gameMode m  start next game in the given mode"+        , "  --newGame  start a new game, overwriting the save file"+        , "  --difficulty n  set difficulty for all UI players to n"+        , "  --stopAfter n  exit this game session after around n seconds"+        , "  --benchmark  print stats, limit saving and other file operations"+        , "  --setDungeonRng s  set dungeon generation RNG seed to string s"+        , "  --setMainRng s  set the main game RNG seed to string s"+        , "  --dumpInitRngs  dump RNG states from the start of the game"+        , "  --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"+        , "  --frontendNo  use no frontend at all (for AIvsAI benchmarks)"+        , "  --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"@@ -92,12 +97,22 @@       parseArgs ("--newGame" : rest) =         let debugSer = parseArgs rest         in debugSer { snewGameSer = True-                    , sdebugCli =-                         (sdebugCli debugSer) {snewGameCli = True}}+                    , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}}+      parseArgs ("--difficulty" : s : rest) =+        let debugSer = parseArgs rest+            diff = 5 - read s+        in debugSer { sdifficultySer = diff+                    , sdebugCli = (sdebugCli debugSer) {sdifficultyCli = diff}}       parseArgs ("--stopAfter" : s : rest) =         (parseArgs rest) {sstopAfter = Just $ read s}-      parseArgs ("--dumpConfig" : rest) =-        (parseArgs rest) {sdumpConfig = True}+      parseArgs ("--benchmark" : rest) =+        (parseArgs rest) {sbenchmark = True}+      parseArgs ("--setDungeonRng" : s : rest) =+        (parseArgs rest) {sdungeonRng = Just $ read s}+      parseArgs ("--setMainRng" : s : rest) =+        (parseArgs rest) {smainRng = Just $ read s}+      parseArgs ("--dumpInitRngs" : rest) =+        (parseArgs rest) {sdumpInitRngs = True}       parseArgs ("--fovMode" : "Digital" : r : rest) | (read r :: Int) > 0 =         (parseArgs rest) {sfovMode = Just $ Digital $ read r}       parseArgs ("--fovMode" : mode : rest) =@@ -124,10 +139,13 @@         let debugSer = parseArgs rest         in debugSer { ssavePrefixSer = Just s                     , sdebugCli =-                         (sdebugCli debugSer) {ssavePrefixCli = Just s}}+                        (sdebugCli debugSer) {ssavePrefixCli = Just s}}       parseArgs ("--frontendStd" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendStd = True}}+      parseArgs ("--frontendNo" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendNo = True}}       parseArgs ("--dbgMsgCli" : rest) =         let debugSer = parseArgs rest         in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}}@@ -146,7 +164,7 @@         -> (Kind.COps -> DebugModeCli             -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer                  -> IO ())-                -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime+                -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer                     -> IO ())                 -> IO ())             -> IO ())
Game/LambdaHack/Server/Action.hs view
@@ -11,9 +11,10 @@   , sendUpdateAI, sendQueryAI, sendPingAI   , sendUpdateUI, sendQueryUI, sendPingUI     -- * Assorted primitives-  , debugPrint, dumpCfg-  , mkConfigRules, restoreScore, revealItems, deduceQuits-  , rndToAction, resetSessionStart, elapsedSessionTimeGT+  , debugPrint, dumpRngs+  , getSetGen, restoreScore, revealItems, deduceQuits+  , rndToAction, resetSessionStart, resetGameStart, elapsedSessionTimeGT+  , tellAllClipPS, tellGameClipPS   , resetFidPerception, getPerFid   , childrenServer   ) where@@ -21,7 +22,8 @@ import Control.Concurrent import Control.Concurrent.STM (TQueue, atomically) import qualified Control.Concurrent.STM as STM-import Control.DeepSeq+import qualified Control.Exception as Ex hiding (handle)+import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St import qualified Data.EnumMap.Strict as EM@@ -39,29 +41,29 @@ import qualified System.Random as R import System.Time -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.ClientCmd-import qualified Game.LambdaHack.Common.ConfigIO as ConfigIO import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore 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 Game.LambdaHack.Common.Save 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.Common.Time import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Frontend as Frontend import Game.LambdaHack.Server.Action.ActionClass-import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.File@@ -81,9 +83,9 @@   cops <- getsState scops   lvl <- getLevel lid   fovMode <- getsServer $ sfovMode . sdebugSer-  s <- getState-  let per = levelPerception cops s (fromMaybe (Digital 12) fovMode) fid lid lvl-      upd = EM.adjust (EM.adjust (const per) lid) fid+  per <- getsState+         $ levelPerception cops (fromMaybe (Digital 12) fovMode) fid lid lvl+  let upd = EM.adjust (EM.adjust (const per) lid) fid   modifyServer $ \ser -> ser {sper = upd (sper ser)}  getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception@@ -95,14 +97,13 @@                               `twith` (lid, fid)) $ EM.lookup lid fper   return $! per --- | Dumps the current game rules configuration to a file.-dumpCfg :: MonadServer m => m String-dumpCfg = do-  Config{configAppDataDir, configRulesCfgFile} <- getsServer sconfig-  let fn = configAppDataDir </> configRulesCfgFile ++ ".dump"-  config <- getsServer sconfig-  liftIO $ ConfigIO.dump config fn-  return fn+-- | Dumps RNG states from the start of the game to a file.+dumpRngs :: MonadServer m => m ()+dumpRngs = do+  dataDir <- liftIO appDataDir+  let fn = dataDir </> "rngs.dump"+  rngs <- getsServer srngs+  liftIO $ writeFile fn (show rngs)  writeTQueueAI :: MonadConnServer m => CmdClientAI -> TQueue CmdClientAI -> m () writeTQueueAI cmd fromServer = do@@ -120,15 +121,15 @@     liftIO $ T.hPutStrLn stderr d   liftIO $ atomically $ STM.writeTQueue fromServer cmd -readTQueueAI :: MonadConnServer m => TQueue CmdSerTakeTime -> m CmdSerTakeTime+readTQueueAI :: MonadConnServer m => TQueue CmdTakeTimeSer -> m CmdTakeTimeSer 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+    let aid = aidCmdTakeTimeSer cmd+    d <- debugAid aid "CmdTakeTimeSer" cmd     liftIO $ T.hPutStrLn stderr d-  return cmd+  return $! cmd  readTQueueUI :: MonadConnServer m => TQueue CmdSer -> m CmdSer readTQueueUI toServer = do@@ -138,14 +139,14 @@     let aid = aidCmdSer cmd     d <- debugAid aid "CmdSer" cmd     liftIO $ T.hPutStrLn stderr d-  return cmd+  return $! cmd  sendUpdateAI :: MonadConnServer m => FactionId -> CmdClientAI -> m () sendUpdateAI fid cmd = do   conn <- getsDict $ snd . (EM.! fid)   writeTQueueAI cmd $ fromServer conn -sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdSerTakeTime+sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdTakeTimeSer sendQueryAI fid aid = do   conn <- getsDict $ snd . (EM.! fid)   writeTQueueAI (CmdQueryAI aid) $ fromServer conn@@ -155,9 +156,9 @@ sendPingAI fid = do   conn <- getsDict $ snd . (EM.! fid)   writeTQueueAI CmdPingAI $ fromServer conn-  -- debugPrint $ "AI client" <+> showT fid <+> "pinged..."+  -- debugPrint $ "AI client" <+> tshow fid <+> "pinged..."   cmdHack <- readTQueueAI $ toServer conn-  -- debugPrint $ "AI client" <+> showT fid <+> "responded."+  -- debugPrint $ "AI client" <+> tshow fid <+> "responded."   assert (cmdHack == WaitSer (toEnum (-1))) skip  sendUpdateUI :: MonadConnServer m => FactionId -> CmdClientUI -> m ()@@ -184,28 +185,41 @@     Nothing -> assert `failure` "no channel for faction" `twith` fid     Just (_, conn) -> do       writeTQueueUI CmdPingUI $ fromServer conn-      -- debugPrint $ "UI client" <+> showT fid <+> "pinged..."+      -- debugPrint $ "UI client" <+> tshow fid <+> "pinged..."       cmdHack <- readTQueueUI $ toServer conn-      -- debugPrint $ "UI client" <+> showT fid <+> "responded."-      assert (cmdHack == TakeTimeSer (WaitSer (toEnum (-1)))) skip+      -- debugPrint $ "UI client" <+> tshow fid <+> "responded."+      assert (cmdHack == CmdTakeTimeSer (WaitSer (toEnum (-1)))) skip +-- TODO: refactor wrt Game.LambdaHack.Common.Save -- | Read the high scores table. Return the empty table if no file.--- Warning: when it's used, the game state--- may still be undefined, hence the config is given as an argument.-restoreScore :: MonadServer m => Config -> m HighScore.ScoreTable-restoreScore Config{configAppDataDir, configScoresFile} = do-  let path = configAppDataDir </> configScoresFile+restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreTable+restoreScore Kind.COps{corule} = do+  let stdRuleset = Kind.stdRuleset corule+      scoresFile = rscoresFile stdRuleset+  dataDir <- liftIO appDataDir+  let path = dataDir </> scoresFile   configExists <- liftIO $ doesFileExist path-  if not configExists-    then return HighScore.empty-    else liftIO $ strictDecodeEOF path+  mscore <- liftIO $ do+    res <- Ex.try $+      if configExists then do+        s <- strictDecodeEOF path+        return $ Just s+      else return Nothing+    let handler :: Ex.SomeException -> IO (Maybe a)+        handler e = do+          let msg = "High score restore failed. The error message is:"+                    <+> (T.unwords . T.lines) (tshow e)+          delayPrint $ msg+          return Nothing+    either handler return res+  maybe (return HighScore.empty) return mscore  -- | Generate a new score, register it and save. registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m () registerScore status mbody fid = do+  cops@Kind.COps{corule} <- getsState scops   assert (maybe True ((fid ==) . bfid) mbody) skip-  factionD <- getsState sfactionD-  let fact = factionD EM.! fid+  fact <- getsState $ (EM.! fid) . sfactionD   assert (playerHuman $ gplayer fact) skip   total <- case mbody of     Just body -> getsState $ snd . calculateTotal body@@ -214,27 +228,70 @@       Just aid -> do         b <- getsState $ getActorBody aid         getsState $ snd . calculateTotal b-  config@Config{configAppDataDir, configScoresFile} <- getsServer sconfig+  let stdRuleset = Kind.stdRuleset corule+      scoresFile = rscoresFile stdRuleset+  dataDir <- liftIO appDataDir   -- Re-read the table in case it's changed by a concurrent game.-  table <- restoreScore config+  table <- restoreScore cops   time <- getsState stime   date <- liftIO getClockTime-  let path = configAppDataDir </> configScoresFile+  DebugModeSer{sdifficultySer} <- getsServer sdebugSer+  let path = dataDir </> scoresFile       saveScore (ntable, _) =         liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable)-  maybe skip saveScore $ HighScore.register table total time status date+      diff | not $ playerUI $ gplayer fact = 0+           | otherwise = sdifficultySer+  maybe skip saveScore $ HighScore.register table total time status date diff  resetSessionStart :: MonadServer m => m () resetSessionStart = do   sstart <- liftIO getClockTime   modifyServer $ \ser -> ser {sstart} +-- TODO: all this breaks when games are loaded; we'd need to save+-- elapsed game clock time to fix this.+resetGameStart :: MonadServer m => m ()+resetGameStart = do+  sgstart <- liftIO getClockTime+  time <- getsState stime+  modifyServer $ \ser ->+    ser {sgstart, sallTime = timeAdd (sallTime ser) time}+ elapsedSessionTimeGT :: MonadServer m => Int -> m Bool elapsedSessionTimeGT stopAfter = do   current <- liftIO getClockTime   TOD s p <- getsServer sstart-  return $ TOD (s + fromIntegral stopAfter) p <= current+  return $! TOD (s + fromIntegral stopAfter) p <= current +tellAllClipPS :: MonadServer m => m ()+tellAllClipPS = do+  bench <- getsServer $ sbenchmark . sdebugSer+  when bench $ do+    TOD s p <- getsServer sstart+    TOD sCur pCur <- liftIO getClockTime+    allTime <- getsServer sallTime+    gtime <- getsState stime+    let time = timeAdd allTime gtime+    let diff = fromIntegral sCur + fromIntegral pCur / 10e12+               - fromIntegral s - fromIntegral p / 10e12+        cps = fromIntegral (timeFit time timeClip) / diff :: Double+    debugPrint $ "Session time:" <+> tshow diff <> "s."+                 <+> "Average clips per second:" <+> tshow cps <> "."++tellGameClipPS :: MonadServer m => m ()+tellGameClipPS = do+  bench <- getsServer $ sbenchmark . sdebugSer+  when bench $ do+    TOD s p <- getsServer sgstart+    unless (s == 0) $ do  -- loaded game, don't report anything+      TOD sCur pCur <- liftIO getClockTime+      time <- getsState stime+      let diff = fromIntegral sCur + fromIntegral pCur / 10e12+                 - fromIntegral s - fromIntegral p / 10e12+          cps = fromIntegral (timeFit time timeClip) / diff :: Double+      debugPrint $ "Game time:" <+> tshow diff <> "s."+                   <+> "Average clips per second:" <+> tshow cps <> "."+ revealItems :: (MonadAtomic m, MonadServer m)             => Maybe FactionId -> Maybe Actor -> m () revealItems mfid mbody = do@@ -288,22 +345,22 @@   factionD <- getsState sfactionD   let assocsInGame = filter (inGame . snd) $ EM.assocs factionD       keysInGame = map fst assocsInGame-      assocsSpawn = filter (isSpawnFact cops . snd) assocsInGame-      assocsNotSummon = filter (not . isSummonFact cops . snd) assocsInGame+      assocsNotHorror = filter (not . isHorrorFact cops . snd) assocsInGame       assocsUI = filter (playerUI . gplayer . snd) assocsInGame-  case assocsNotSummon of+  case assocsNotHorror of     _ | null assocsUI ->-      -- All non-UI players left in the game win.+      -- Only non-UI players left in the game and they all win.       mapQuitF status{stOutcome=Conquer} keysInGame     [] ->-      -- Only summons remain so all win, UI or human or not, allied or not.+      -- Only horrors remain, so they win.       mapQuitF status{stOutcome=Conquer} keysInGame-    (_, fact1) : rest | null assocsSpawn && all (isAllied fact1 . fst) rest ->-      -- Only one allied team remains in a no-spawners game.+    (_, fact1) : rest | all (not . isAtWar fact1 . fst) rest ->+      -- Nobody is at war any more, so all win.+      -- TODO: check not at war with each other.       mapQuitF status{stOutcome=Conquer} keysInGame     _ | stOutcome status == Escape -> do-      -- Otherwise, in a spawners game or a game with many teams alive,-      -- only complete Victory matters.+      -- Otherwise, in a game with many warring teams alive,+      -- only complete Victory matters, until enough of them die.       let (victors, losers) = partition (flip isAllied fid . snd) assocsInGame       mapQuitF status{stOutcome=Escape} $ map fst victors       mapQuitF status{stOutcome=Defeated} $ map fst losers@@ -312,18 +369,14 @@ tryRestore :: MonadServer m            => Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer)) tryRestore Kind.COps{corule} sdebugSer = do-  let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule+  let stdRuleset = Kind.stdRuleset corule+      scoresFile = rscoresFile stdRuleset+      pathsDataFile = rpathsDataFile stdRuleset       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.-  (Config{ configAppDataDir-         , configRulesCfgFile-         , configScoresFile }, _, _) <- mkConfigRules corule Nothing-  let copies =-        [ (configRulesCfgFile <.> ".default", configRulesCfgFile <.> ".ini")-        , (configScoresFile, configScoresFile) ]+  let copies = [( "GameDefinition" </> scoresFile+                , scoresFile )]       name = fromMaybe "save" prefix <.> saveName-  liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile+  liftIO $ Save.restoreGame name copies pathsDataFile  -- Global variable for all children threads of the server. childrenServer :: MVar [MVar ()]@@ -339,7 +392,7 @@                -> ChanServer CmdClientUI CmdSer                -> IO ())            -> (FactionId-               -> ChanServer CmdClientAI CmdSerTakeTime+               -> ChanServer CmdClientAI CmdTakeTimeSer                -> IO ())            -> m () updateConn executorUI executorAI = do@@ -349,7 +402,7 @@       mkChanServer = do         fromServer <- STM.newTQueueIO         toServer <- STM.newTQueueIO-        return ChanServer{..}+        return $! ChanServer{..}       mkChanFrontend :: IO Frontend.ChanFrontend       mkChanFrontend = STM.newTQueueIO       addConn :: FactionId -> Faction -> IO ConnServerFaction@@ -417,62 +470,13 @@   g <- getsServer srandom   let (a, ng) = St.runState r g   modifyServer $ \ser -> ser {srandom = ng}-  return a---- | Gets a random generator from the config or,--- if not present, generates one and updates the config with it.-getSetGen :: ConfigIO.CP      -- ^ config-          -> String  -- ^ name of the generator-          -> Maybe R.StdGen-          -> IO (R.StdGen, ConfigIO.CP)-getSetGen config option mrandom =-  case ConfigIO.getOption config "engine" option of-    Just sg -> return (read sg, config)-    Nothing -> do-      -- Pick the randomly chosen generator from the IO monad (unless given)-      -- and record it in the config for debugging (can be 'D'umped).-      g <- case mrandom of-        Just rnd -> return rnd-        Nothing -> R.newStdGen-      let gs = show g-          c = ConfigIO.set config "engine" option gs-      return (g, c)--parseConfigRules :: FilePath -> ConfigIO.CP -> Config-parseConfigRules dataDir cp =-  let configSelfString = ConfigIO.to_string cp-      configFirstDeathEnds = ConfigIO.get cp "engine" "firstDeathEnds"-      configFovMode = ConfigIO.get cp "engine" "fovMode"-      configSaveBkpClips = ConfigIO.get cp "engine" "saveBkpClips"-      configAppDataDir = dataDir-      configScoresFile = ConfigIO.get cp "file" "scoresFile"-      configRulesCfgFile = "config.rules"-      configSavePrefix = ConfigIO.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" `twith` ident-            section = ConfigIO.getItems cp "heroName"-        in map toNumber section-  in Config{..}+  return $! a --- | Read and parse rules config file and supplement it with random seeds.--- This creates 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-              => Kind.Ops RuleKind -> Maybe R.StdGen-              -> m (Config, R.StdGen, R.StdGen)-mkConfigRules corule mrandom = do-  let cpRulesDefault = rcfgRulesDefault $ Kind.stdRuleset corule-  dataDir <--    liftIO $ ConfigIO.appDataDir-  cpRules <--    liftIO $ ConfigIO.mkConfig cpRulesDefault $ dataDir </> "config.rules.ini"-  (dungeonGen,  cp2) <--    liftIO $ getSetGen cpRules "dungeonRandomGenerator" mrandom-  (startingGen, cp3) <--    liftIO $ getSetGen cp2     "startingRandomGenerator" mrandom-  let conf = parseConfigRules dataDir cp3-  -- Catch syntax errors ASAP.-  return $! deepseq conf (conf, dungeonGen, startingGen)+-- | Gets a random generator from the arguments or, if not present,+-- generates one.+getSetGen :: MonadServer m+          => Maybe R.StdGen+          -> m R.StdGen+getSetGen mrng = case mrng of+  Just rnd -> return rnd+  Nothing -> liftIO $ R.newStdGen
Game/LambdaHack/Server/Action/ActionType.hs view
@@ -19,7 +19,6 @@ 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@@ -39,18 +38,22 @@   getsState f = ActionSer $ gets $ f . serState  instance MonadAction ActionSer where-  modifyState f =-    ActionSer $ modify $ \serS -> serS {serState = f $ serState serS}-  putState    s =-    ActionSer $ modify $ \serS -> serS {serState = s}+  modifyState f = ActionSer $ state $ \serS ->+    let newSerS = serS {serState = f $ serState serS}+    in newSerS `seq` ((), newSerS)+  putState    s = ActionSer $ state $ \serS ->+    let newSerS = serS {serState = s}+    in newSerS `seq` ((), newSerS)  instance MonadServer ActionSer where   getServer      = ActionSer $ gets serServer   getsServer   f = ActionSer $ gets $ f . serServer-  modifyServer f =-    ActionSer $ modify $ \serS -> serS {serServer = f $ serServer serS}-  putServer    s =-    ActionSer $ modify $ \serS -> serS {serServer = s}+  modifyServer f = ActionSer $ state $ \serS ->+    let newSerS = serS {serServer = f $ serServer serS}+    in newSerS `seq` ((), newSerS)+  putServer    s = ActionSer $ state $ \serS ->+    let newSerS = serS {serServer = s}+    in newSerS `seq` ((), newSerS)   liftIO         = ActionSer . IO.liftIO   saveServer     = ActionSer $ do     s <- gets serState@@ -70,14 +73,13 @@ executorSer :: ActionSer () -> IO () executorSer m =   let saveFile (_, ser) =-        configAppDataDir (sconfig ser)-        </> fromMaybe "save" (ssavePrefixSer (sdebugSer ser))+        fromMaybe "save" (ssavePrefixSer (sdebugSer ser))         <.> saveName-      exe toSave =+      exe serToSave =         evalStateT (runActionSer m)           SerState { serState = emptyState                    , serServer = emptyStateServer                    , serDict = EM.empty-                   , serToSave = toSave+                   , serToSave                    }   in Save.wrapInSaves saveFile exe
Game/LambdaHack/Server/AtomicSemSer.hs view
@@ -5,6 +5,7 @@   ( atomicSendSem   ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES@@ -25,7 +26,6 @@ import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.Action import Game.LambdaHack.Server.State-import Control.Exception.Assert.Sugar  storeUndo :: MonadServer m => Atomic -> m () storeUndo _atomic =@@ -101,14 +101,12 @@           resetFidPerception fid lid           perNew <- getPerFid fid lid           let inPer = diffPer perNew perOld-              inPA = perActor inPer               outPer = diffPer perOld perNew-              outPA = perActor outPer-          if EM.null outPA && EM.null inPA+          if nullPer outPer && nullPer inPer             then anySend fid perOld perOld             else do-              sendA fid $ PerceptionA lid outPA inPA               unless knowEvents $ do  -- inconsistencies would quickly manifest+                sendA fid $ PerceptionA lid outPer inPer                 let remember = atomicRemember lid inPer sOld                     seenNew = seenAtomicCli False fid perNew                     seenOld = seenAtomicCli False fid perOld@@ -147,8 +145,8 @@   let inFov = ES.elems $ totalVisible inPer       lvl = sdungeon s EM.! lid       -- Actors.-      inPrio = mapMaybe (\p -> posToActor p lid s) inFov-      fActor aid = SpotActorA aid (getActorBody aid s) (getActorItem aid s)+      inPrio = concatMap (\p -> posToActors p lid s) inFov+      fActor ((aid, b), ais) = SpotActorA aid b ais       inActor = map fActor inPrio       -- Items.       pMaybe p = maybe Nothing (\x -> Just (p, x))@@ -171,7 +169,6 @@       -- TODO: make floor paths from hidden tiles       -- TODO: perhaps decrease secrecy as lseen, ltime or lsmell increases       -- or a per-party counter increases-      -- TODO: give spawning factions a bonus to searching       -- Smells.       inSmellFov = ES.elems $ smellVisible inPer       inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov
− Game/LambdaHack/Server/Config.hs 
@@ -1,53 +0,0 @@--- | Personal game configuration file type definitions.-module Game.LambdaHack.Server.Config-  ( Config(..)-  ) where--import Control.DeepSeq-import Data.Binary-import Data.Text (Text)--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-    -- engine-  , configFirstDeathEnds :: !Bool-  , configFovMode        :: !FovMode-  , configSaveBkpClips   :: !Int-    -- files-  , configAppDataDir     :: !FilePath-  , configScoresFile     :: !FilePath-  , configRulesCfgFile   :: !FilePath-  , configSavePrefix     :: !String-    -- heroNames-  , configHeroNames      :: ![(Int, Text)]-  }-  deriving Show--instance NFData Config--instance Binary Config where-  put Config{..} = do-    put configSelfString-    put configFirstDeathEnds-    put configFovMode-    put configSaveBkpClips-    put configAppDataDir-    put configScoresFile-    put configRulesCfgFile-    put configSavePrefix-    put configHeroNames-  get = do-    configSelfString     <- get-    configFirstDeathEnds <- get-    configFovMode        <- get-    configSaveBkpClips <- get-    configAppDataDir     <- get-    configScoresFile     <- get-    configRulesCfgFile   <- get-    configSavePrefix <- get-    configHeroNames      <- get-    return Config{..}
Game/LambdaHack/Server/DungeonGen.hs view
@@ -3,7 +3,7 @@   ( FreshDungeon(..), dungeonGen   ) where -import Control.Arrow (first)+import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.List@@ -15,7 +15,7 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.PointXY+import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time@@ -23,24 +23,23 @@ import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.DungeonGen.Area-import Game.LambdaHack.Server.DungeonGen.Cave hiding (TileMapXY)+import Game.LambdaHack.Server.DungeonGen.Cave import Game.LambdaHack.Server.DungeonGen.Place-import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency --convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapXY+convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapEM                 -> Rnd TileMap convertTileMaps cdefTile cxsize cysize ltile = do-  let bounds = (origin, toPoint cxsize $ PointXY (cxsize - 1, cysize - 1))-      assocs = map (first (toPoint cxsize)) (EM.assocs ltile)-  pickedTiles <- replicateM (cxsize * cysize) cdefTile-  return $ Kind.listArray bounds pickedTiles Kind.// assocs+  let f :: Point -> Rnd (Kind.Id TileKind)+      f p = case EM.lookup p ltile of+        Just t -> return t+        Nothing -> cdefTile+  PointArray.generateMA cxsize cysize f  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+  let dist cmin l _ = all (\pos -> chessDist l pos > cmin) ps   findPosTry 1000 cmap     (\p t -> Tile.hasFeature cotile F.CanActor t              && dist 0 p t)  -- can't overwrite stairs with other stairs@@ -57,15 +56,15 @@                          , cocave=Kind.Ops{okind=cokind} }            Cave{..} ldepth minD maxD nstairUp escapeFeature = do   let kc@CaveKind{..} = cokind dkind-      fitArea pos = inside cxsize pos . fromArea . qarea-      findLegend pos = maybe clitLegendTile qlegend+      fitArea pos = inside pos . fromArea . qarea+      findLegend pos = maybe clegendLitTile qlegend                        $ find (fitArea pos) dplaces-      hasEscapeAndSymbol sym t = Tile.kindHasFeature (F.Cause Effect.Escape) t-                                 && tsymbol t == sym+      hasEscape p t = Tile.kindHasFeature (F.Cause $ Effect.Escape p) t       ascendable  = Tile.kindHasFeature $ F.Cause (Effect.Ascend 1)       descendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend (-1))       dcond kt = not (Tile.kindHasFeature F.Clear kt)-                 || (if dnight then not else id) (Tile.kindHasFeature F.Lit kt)+                 || (if dnight then id else not)+                      (Tile.kindHasFeature F.Dark kt)       pickDefTile = fmap (fromMaybe $ assert `failure` cdefTile)                     $ opick cdefTile dcond   cmap <- convertTileMaps pickDefTile cxsize cysize dmap@@ -93,7 +92,7 @@           let st = (spos, stairId)               asc = ascendable $ okind stairId               desc = descendable $ okind stairId-          return $ case (asc, desc) of+          return $! case (asc, desc) of                      (True, False) -> (st : up, down, upDown)                      (False, True) -> (up, st : down, upDown)                      (True, True)  -> (up, down, st : upDown)@@ -122,15 +121,15 @@               Just True -> do                 let legend = findLegend epos                 upEscape <- fmap (fromMaybe $ assert `failure` legend)-                            $ opick legend $ hasEscapeAndSymbol '<'+                            $ opick legend $ hasEscape 1                 return [(epos, upEscape)]               Just False -> do                 let legend = findLegend epos                 downEscape <- fmap (fromMaybe $ assert `failure` legend)-                              $ opick legend $ hasEscapeAndSymbol '>'+                              $ opick legend $ hasEscape (-1)                 return [(epos, downEscape)]   let exits = stairsTotal ++ escape-      ltile = cmap Kind.// exits+      ltile = cmap PointArray.// exits       -- We reverse the order in down stairs, to minimize long stair chains.       lstair = ( map fst $ stairsUp ++ stairsUpDown                , map fst $ stairsUpDown ++ stairsDown )@@ -140,14 +139,15 @@   assert (not $ nullFreq itemFreq) skip   lsecret <- random   return $! levelFromCaveKind cops kc ldepth ltile lstair-                              litemNum itemFreq lsecret+                              litemNum itemFreq lsecret (isJust escapeFeature)  levelFromCaveKind :: Kind.COps                   -> CaveKind -> Int -> TileMap -> ([Point], [Point])-                  -> Int -> Frequency Text -> Int+                  -> Int -> Frequency Text -> Int -> Bool                   -> Level levelFromCaveKind Kind.COps{cotile}-                  CaveKind{..} ldepth ltile lstair litemNum litemFreq lsecret =+                  CaveKind{..}+                  ldepth ltile lstair litemNum litemFreq lsecret lescape =   Level     { ldepth     , lprio = EM.empty@@ -159,14 +159,15 @@     , ldesc = cname     , lstair     , lseen = 0-    , lclear = let f !n !tk | Tile.isExplorable cotile tk = n + 1-                            | otherwise = n-               in Kind.foldlArray f 0 ltile+    , lclear = let f n t | Tile.isExplorable cotile t = n + 1+                         | otherwise = n+               in PointArray.foldlA f 0 ltile     , ltime = timeTurn     , litemNum     , litemFreq     , lsecret     , lhidden = chidden+    , lescape     }  findGenerator :: Kind.COps -> Caves@@ -210,4 +211,4 @@   assert (nstairUpLast == 0) skip   let freshDungeon = EM.fromList levels       freshDepth = totalDepth-  return FreshDungeon{..}+  return $! FreshDungeon{..}
Game/LambdaHack/Server/DungeonGen/Area.hs view
@@ -5,7 +5,7 @@  import Data.Binary -import Game.LambdaHack.Common.PointXY+import Game.LambdaHack.Common.Point  -- | The type of areas. The bottom left and the top right points. data Area = Area !X !Y !X !Y@@ -20,19 +20,19 @@ fromArea :: Area -> (X, Y, X, Y) fromArea (Area x0 y0 x1 y1) = (x0, y0, x1, y1) -trivialArea :: PointXY -> Area-trivialArea (PointXY (x, y)) = Area x y x y+trivialArea :: Point -> Area+trivialArea (Point x y) = Area x y x y  -- | Divide uniformly a larger area into the given number of smaller areas -- overlapping at the edges.-grid :: (X, Y) -> Area -> [(PointXY, Area)]+grid :: (X, Y) -> Area -> [(Point, Area)] grid (nx, ny) (Area x0 y0 x1 y1) =   let xd = x1 - x0  -- not +1, because we need overlap       yd = y1 - y0-  in [ (PointXY (x, y), Area (x0 + xd * x `div` nx)-                             (y0 + yd * y `div` ny)-                             (x0 + xd * (x + 1) `div` nx)-                             (y0 + yd * (y + 1) `div` ny))+  in [ (Point x y, Area (x0 + xd * x `div` nx)+                          (y0 + yd * y `div` ny)+                          (x0 + xd * (x + 1) `div` nx)+                          (y0 + yd * (y + 1) `div` ny))      | x <- [0..nx-1], y <- [0..ny-1] ]  -- | Enlarge (or shrink) the given area on all fours sides by the amount.
Game/LambdaHack/Server/DungeonGen/AreaRnd.hs view
@@ -8,24 +8,24 @@   , Corridor, connectPlaces   ) where -import qualified Data.EnumSet as ES+import Control.Exception.Assert.Sugar import Data.Maybe+import qualified Data.Set as S -import Game.LambdaHack.Common.PointXY+import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.VectorXY+import Game.LambdaHack.Common.Vector import Game.LambdaHack.Server.DungeonGen.Area-import Control.Exception.Assert.Sugar  -- Picking random points inside areas  -- | Pick a random point within an area.-xyInArea :: Area -> Rnd PointXY+xyInArea :: Area -> Rnd Point xyInArea area = do   let (x0, y0, x1, y1) = fromArea area   rx <- randomR (x0, x1)   ry <- randomR (y0, y1)-  return $ PointXY (rx, ry)+  return $! Point rx ry  -- | Create a random room according to given parameters. mkRoom :: (X, Y)    -- ^ minimum size@@ -37,17 +37,17 @@   assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) skip   let a0 = (x0, y0, x1 - xm + 1, y1 - ym + 1)       area0 = fromMaybe (assert `failure` a0) $ toArea a0-  PointXY (rx0, ry0) <- xyInArea area0+  Point rx0 ry0 <- xyInArea area0   let sX = rx0 + xm - 1       sY = ry0 + ym - 1       eX = min x1 (rx0 + xM - 1)       eY = min y1 (ry0 + yM - 1)       a1 = (sX, sY, eX, eY)       area1 = fromMaybe (assert `failure` a1) $ toArea a1-  PointXY (rx1, ry1) <- xyInArea area1+  Point rx1 ry1 <- xyInArea area1   let a3 = (rx0, ry0, rx1, ry1)       area3 = fromMaybe (assert `failure` a3) $ toArea a3-  return area3+  return $! area3  -- | Create a void room, i.e., a single point area within the designated area. mkVoidRoom :: Area -> Rnd Area@@ -55,45 +55,50 @@   -- Pass corridors closer to the middle of the grid area, if possible.   let core = fromMaybe area $ shrink area   pxy <- xyInArea core-  return $ trivialArea pxy+  return $! trivialArea pxy  -- Choosing connections between areas in a grid  -- | Pick a subset of connections between adjacent areas within a grid until -- there is only one connected component in the graph of all areas.-connectGrid :: (X, Y) -> Rnd [(PointXY, PointXY)]+connectGrid :: (X, Y) -> Rnd [(Point, Point)] connectGrid (nx, ny) = do-  let unconnected = ES.fromList [ PointXY (x, y)+  let unconnected = S.fromList [ Point x y                                 | x <- [0..nx-1], y <- [0..ny-1] ]   -- Candidates are neighbours that are still unconnected. We start with   -- a random choice.   rx <- randomR (0, nx-1)   ry <- randomR (0, ny-1)-  let candidates = ES.fromList [ PointXY (rx, ry) ]+  let candidates = S.fromList [Point rx ry]   connectGrid' (nx, ny) unconnected candidates [] -connectGrid' :: (X, Y) -> ES.EnumSet PointXY -> ES.EnumSet PointXY-             -> [(PointXY, PointXY)]-             -> Rnd [(PointXY, PointXY)]+connectGrid' :: (X, Y) -> S.Set Point -> S.Set Point+             -> [(Point, Point)]+             -> Rnd [(Point, Point)] connectGrid' (nx, ny) unconnected candidates acc-  | ES.null candidates = return $ map sortPointXY acc+  | S.null candidates = return $! map sortPoint acc   | otherwise = do-      c <- oneOf (ES.toList candidates)+      c <- oneOf (S.toList candidates)       -- potential new candidates:-      let ns = ES.fromList $ vicinityCardinalXY (0, 0, nx-1, ny-1) c-          nu = ES.delete c unconnected  -- new unconnected+      let ns = S.fromList $ vicinityCardinal nx ny c+          nu = S.delete c unconnected  -- new unconnected           -- (new candidates, potential connections):-          (nc, ds) = ES.partition (`ES.member` nu) ns-      new <- if ES.null ds+          (nc, ds) = S.partition (`S.member` nu) ns+      new <- if S.null ds              then return id              else do-               d <- oneOf (ES.toList ds)+               d <- oneOf (S.toList ds)                return ((c, d) :)       connectGrid' (nx, ny) nu-        (ES.delete c (candidates `ES.union` nc)) (new acc)+        (S.delete c (candidates `S.union` nc)) (new acc) +-- | Sort the sequence of two points, in the derived lexicographic order.+sortPoint :: (Point, Point) -> (Point, Point)+sortPoint (a, b) | a <= b    = (a, b)+                   | otherwise = (b, a)+ -- | Pick a single random connection between adjacent areas within a grid.-randomConnection :: (X, Y) -> Rnd (PointXY, PointXY)+randomConnection :: (X, Y) -> Rnd (Point, Point) randomConnection (nx, ny) =   assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` "wrong connection"                                                `twith` (nx, ny)) $ do@@ -102,11 +107,11 @@     then do       rx  <- randomR (0, nx-2)       ry  <- randomR (0, ny-1)-      return (PointXY (rx, ry), PointXY (rx+1, ry))+      return (Point rx ry, Point (rx+1) ry)     else do       rx  <- randomR (0, nx-1)       ry  <- randomR (0, ny-2)-      return (PointXY (rx, ry), PointXY (rx, ry+1))+      return (Point rx ry, Point rx (ry+1))  -- Plotting individual corridors between two areas @@ -114,20 +119,20 @@ data HV = Horiz | Vert  -- | The coordinates of consecutive fields of a corridor.-type Corridor = [PointXY]+type Corridor = [Point]  -- | Create a corridor, either horizontal or vertical, with -- a possible intermediate part that is in the opposite direction. mkCorridor :: HV            -- ^ orientation of the starting section-           -> PointXY       -- ^ starting point-           -> PointXY       -- ^ ending point+           -> Point       -- ^ starting point+           -> Point       -- ^ ending point            -> Area          -- ^ the area containing the intermediate point            -> Rnd Corridor  -- ^ straight sections of the corridor-mkCorridor hv (PointXY (x0, y0)) (PointXY (x1, y1)) b = do-  PointXY (rx, ry) <- xyInArea b-  case hv of-    Horiz -> return $ map PointXY [(x0, y0), (rx, y0), (rx, y1), (x1, y1)]-    Vert  -> return $ map PointXY [(x0, y0), (x0, ry), (x1, ry), (x1, y1)]+mkCorridor hv (Point x0 y0) (Point x1 y1) b = do+  Point rx ry <- xyInArea b+  return $! map (uncurry Point) $ case hv of+    Horiz -> [(x0, y0), (rx, y0), (rx, y1), (x1, y1)]+    Vert  -> [(x0, y0), (x0, ry), (x1, ry), (x1, y1)]  -- | Try to connect two interiors of places with a corridor. -- Choose entrances at least 4 or 3 tiles distant from the edges, if the place@@ -150,8 +155,8 @@             (nx0, nx1) = trim4 (x0, x1)             (ny0, ny1) = trim4 (y0, y1)         in fromMaybe (assert `failure` area) $ toArea (nx0, ny0, nx1, ny1)-  PointXY (sx, sy) <- xyInArea $ trim so-  PointXY (tx, ty) <- xyInArea $ trim to+  Point sx sy <- xyInArea $ trim so+  Point tx ty <- xyInArea $ trim to   let hva sarea tarea = do         let (_, _, zsx1, zsy1) = fromArea sarea             (ztx0, zty0, _, _) = fromArea tarea@@ -176,8 +181,8 @@   -- We cross width one places completely with the corridor, for void   -- rooms and others (e.g., one-tile wall room then becomes a door, etc.).   let (p0, p1) = case hv of-        Horiz -> (PointXY (sox1, sy), PointXY (tox0, ty))-        Vert  -> (PointXY (sx, soy1), PointXY (tx, toy0))+        Horiz -> (Point sox1 sy, Point tox0 ty)+        Vert  -> (Point sx soy1, Point tx toy0)   -- The condition imposed on mkCorridor are tricky: there might not always   -- exist a good intermediate point if the places are allowed to be close   -- together and then we let the intermediate part degenerate.
Game/LambdaHack/Server/DungeonGen/Cave.hs view
@@ -1,18 +1,19 @@ -- | Generation of caves (not yet inhabited dungeon levels) from cave kinds. module Game.LambdaHack.Server.DungeonGen.Cave-  ( TileMapXY, ItemFloorXY, Cave(..), buildCave+  ( Cave(..), buildCave   ) where  import Control.Arrow ((&&&))+import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM-import qualified Data.List as L+import Data.List+import qualified Data.Map.Strict as M import Data.Maybe+import qualified Data.Traversable as Traversable -import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.PointXY+import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.CaveKind@@ -20,24 +21,12 @@ import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.DungeonGen.Area import Game.LambdaHack.Server.DungeonGen.AreaRnd-import Game.LambdaHack.Server.DungeonGen.Place hiding (TileMapXY)-import qualified Game.LambdaHack.Server.DungeonGen.Place as Place-import Control.Exception.Assert.Sugar---- | The map of tile kinds in a cave.--- The map is sparse. The default tile that eventually fills the empty spaces--- is specified in the cave kind specification with @cdefTile@.-type TileMapXY = Place.TileMapXY---- | The map of starting items in tiles of a cave. The map is sparse.--- Unspecified tiles have no starting items.-type ItemFloorXY = EM.EnumMap PointXY (Item, Int)+import Game.LambdaHack.Server.DungeonGen.Place  -- | 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+  , dmap    :: !TileMapEM           -- ^ tile kinds in the cave   , dplaces :: ![Place]             -- ^ places generated in the cave   , dnight  :: !Bool                -- ^ whether the cave is dark   }@@ -72,20 +61,21 @@           -> Int               -- ^ maximum depth of the dungeon           -> Kind.Id CaveKind  -- ^ cave kind to use for generation           -> Rnd Cave-buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{ opick-                                                , ouniqGroup }+buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{opick}                         , cocave=Kind.Ops{okind}                         , coplace=Kind.Ops{okind=pokind} }-          ln depth ci = do-  let kc@CaveKind{..} = okind ci+          ln depth dkind = do+  let kc@CaveKind{..} = okind dkind   lgrid@(gx, gy) <- castDiceXY cgrid   -- Make sure that in caves not filled with rock, there is a passage   -- across the cave, even if a single room blocks most of the cave.+  -- Also, ensure fancy outer fences are not obstructed by room walls.   let fullArea = fromMaybe (assert `failure` kc)                  $ toArea (0, 0, cxsize - 1, cysize - 1)       subFullArea = fromMaybe (assert `failure` kc)                     $ toArea (1, 1, cxsize - 2, cysize - 2)-      area | gx == 1 || gy == 1 = subFullArea+      area | gx * gy == 1+             || couterFenceTile /= "basic outer fence" = subFullArea            | otherwise = fullArea       gs = grid lgrid area   (addedConnects, voidPlaces) <- do@@ -110,8 +100,7 @@                            else fmap Right $ mkRoom minPlaceSize                                                     maxPlaceSize innerArea                      return (i, r')) gs-  let hardRockId = ouniqGroup "outer fence"-      fence = buildFence hardRockId subFullArea+  fence <- buildFenceRnd cops couterFenceTile subFullArea   dnight <- chanceDeep ln depth cnightChance   darkCorTile <- fmap (fromMaybe $ assert `failure` cdarkCorTile)                  $ opick cdarkCorTile (const True)@@ -120,12 +109,13 @@   let pickedCorTile = if dnight then darkCorTile else litCorTile       addPl (m, pls, qls) (i, Left r) = return (m, pls, (i, Left r) : qls)       addPl (m, pls, qls) (i, Right r) = do-        (tmap, place) <- buildPlace cops kc darkCorTile litCorTile ln depth r+        (tmap, place) <-+          buildPlace cops kc dnight darkCorTile litCorTile ln depth r         return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls)   (lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0   connects <- connectGrid lgrid-  let allConnects = L.union connects addedConnects  -- no duplicates-      qplaces = EM.fromList qplaces0+  let allConnects = union connects addedConnects  -- no duplicates+      qplaces = M.fromList qplaces0   cs <- mapM (\(p0, p1) -> do                 let shrinkPlace (r, Place{qkind}) =                       case shrink r of@@ -139,45 +129,47 @@                               Just mergeArea -> (mergeArea, r)                           _ -> (sr, sr)                     shrinkForFence = either (id &&& id) shrinkPlace-                    rr0 = shrinkForFence $ qplaces EM.! p0-                    rr1 = shrinkForFence $ qplaces EM.! p1+                    rr0 = shrinkForFence $ qplaces M.! p0+                    rr1 = shrinkForFence $ qplaces M.! p1                 connectPlaces rr0 rr1) allConnects-  let lcorridors = EM.unions (L.map (digCorridors pickedCorTile) cs)+  let lcorridors = EM.unions (map (digCorridors pickedCorTile) cs)       lm = EM.unionWith (mergeCorridor cotile) lcorridors lplaces   -- Convert wall openings into doors, possibly.-  let f l (p, t) =-        if not $ Tile.hasFeature cotile F.Suspect t-        then return l  -- no opening to start with+  let f t =+        if not $ Tile.isSuspect cotile t+          -- May also turn a cache into a floor (and/or a pillar?); tough luck.+          -- TODO: the floor may be lit while it should be dark.+        then return t  -- 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+            let cor = if Tile.isLit cotile t then litCorTile else darkCorTile+            in return $! cor  -- opening kept           else do             ro <- chance copenChance             doorClosedId <- Tile.revealAs cotile t             if not ro then-              return $ EM.insert p doorClosedId l+              return $! doorClosedId             else do               doorOpenId <- Tile.openTo cotile doorClosedId-              return $ EM.insert p doorOpenId l-  dmap <- foldM f lm (EM.assocs lm)+              return $! doorOpenId+  dmap <- Traversable.mapM f lm   let cave = Cave-        { dkind = ci-        , ditem = EM.empty+        { dkind         , dmap         , dplaces         , dnight         }-  return cave+  return $! cave -digCorridors :: Kind.Id TileKind -> Corridor -> TileMapXY+digCorridors :: Kind.Id TileKind -> Corridor -> TileMapEM digCorridors tile (p1:p2:ps) =   EM.union corPos (digCorridors tile (p2:ps))  where-  corXY  = fromTo p1 p2-  corPos = EM.fromList $ L.zip corXY (repeat tile)+  cor  = fromTo p1 p2+  corPos = EM.fromList $ zip cor (repeat tile) digCorridors _ _ = EM.empty  mergeCorridor :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind
Game/LambdaHack/Server/DungeonGen/Place.hs view
@@ -1,26 +1,25 @@ {-# LANGUAGE RankNTypes #-} -- | Generation of places from place kinds. module Game.LambdaHack.Server.DungeonGen.Place-  ( TileMapXY, Place(..), placeCheck, buildFence, buildPlace+  ( TileMapEM, Place(..), placeCheck, buildFenceRnd, buildPlace   ) where +import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.List as L import Data.Maybe import Data.Text (Text) import qualified Data.Text as T  import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.PointXY+import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.DungeonGen.Area-import Control.Exception.Assert.Sugar  -- TODO: use more, rewrite as needed, document each field. -- | The parameters of a place. Most are immutable and set@@ -38,7 +37,7 @@ -- | The map of tile kinds in a place (and generally anywhere in a cave). -- The map is sparse. The default tile that eventually fills the empty spaces -- is specified in the cave kind specification with @cdefTile@.-type TileMapXY = EM.EnumMap PointXY (Kind.Id TileKind)+type TileMapEM = EM.EnumMap Point (Kind.Id TileKind)  -- | For @CAlternate@ tiling, require the place be comprised -- of an even number of whole corners, with exactly one square@@ -56,7 +55,7 @@           dx = x1 - x0 + 1           dy = y1 - y0 + 1           dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l-          dycorner = L.length ptopLeft+          dycorner = length ptopLeft           wholeOverlapped d dcorner = d > 1 && dcorner > 1 &&                                       (d - 1) `mod` (2 * (dcorner - 1)) == 0       in case pcover of@@ -80,15 +79,16 @@ -- and fill a cave section acccording to it. buildPlace :: Kind.COps         -- ^ the game content            -> CaveKind          -- ^ current cave kind+           -> Bool              -- ^ whether the cave is dark            -> Kind.Id TileKind  -- ^ dark fence tile, if fence hollow            -> Kind.Id TileKind  -- ^ lit fence tile, if fence hollow            -> Int               -- ^ current level depth            -> Int               -- ^ maximum depth            -> Area              -- ^ whole area of the place, fence included-           -> Rnd (TileMapXY, Place)+           -> Rnd (TileMapEM, Place) buildPlace Kind.COps{ cotile=cotile@Kind.Ops{opick=opick}                     , coplace=Kind.Ops{okind=pokind, opick=popick} }-           CaveKind{..} darkCorTile litCorTile ln depth r = do+           CaveKind{..} dnight darkCorTile litCorTile ln depth r = do   qsolidFence <- fmap (fromMaybe $ assert `failure` cfillerTile)                  $ opick cfillerTile (const True)   dark <- chanceDeep ln depth cdarkChance@@ -97,56 +97,75 @@            $ popick cave (placeCheck r)   let qhollowFence = if dark then darkCorTile else litCorTile       kr = pokind qkind-      qlegend = if dark then cdarkLegendTile else clitLegendTile+      qlegend = if dark then clegendDarkTile else clegendLitTile       qseen = False       qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea (pfence kr) r       place = Place {..}   legend <- olegend cotile qlegend+  legendLit <- olegend cotile clegendLitTile   let xlegend = EM.insert 'X' qhollowFence legend-  return (digPlace place kr xlegend, place)+      xlegendLit = EM.insert 'X' qhollowFence legendLit+      cmap = tilePlace qarea kr+      fence = case pfence kr of+        FWall -> buildFence qsolidFence qarea+        FFloor -> buildFence qhollowFence qarea+        FNone -> EM.empty+      (x0, y0, x1, y1) = fromArea qarea+      isEdge (Point x y) = x `elem` [x0, x1] || y `elem` [y0, y1]+      digNight xy c | isEdge xy = xlegendLit EM.! c+                    | otherwise = xlegend EM.! c+      interior = case pfence kr of+        FNone | not dnight -> EM.mapWithKey digNight cmap+        _ -> EM.map (xlegend EM.!) cmap+      tmap = EM.union interior fence+  return (tmap, place)  -- | Roll a legend of a place plan: a map from plan symbols to tile kinds. olegend :: Kind.Ops TileKind -> Text         -> Rnd (EM.EnumMap Char (Kind.Id TileKind))-olegend Kind.Ops{ofoldrWithKey, opick} group =+olegend Kind.Ops{ofoldrWithKey, opick} cgroup =   let getSymbols _ tk acc =         maybe acc (const $ ES.insert (tsymbol tk) acc)-          (L.lookup group $ tfreq tk)+          (lookup cgroup $ tfreq tk)       symbols = ofoldrWithKey getSymbols ES.empty       getLegend s acc = do         m <- acc-        tk <- fmap (fromMaybe $ assert `failure` (group, s))-              $ opick group $ (== s) . tsymbol-        return $ EM.insert s tk m+        tk <- fmap (fromMaybe $ assert `failure` (cgroup, s))+              $ opick cgroup $ (== s) . tsymbol+        return $! EM.insert s tk m       legend = ES.foldr getLegend (return EM.empty) symbols   in legend  -- | Construct a fence around an area, with the given tile kind.-buildFence :: Kind.Id TileKind -> Area -> TileMapXY+buildFence :: Kind.Id TileKind -> Area -> TileMapEM buildFence fenceId area =   let (x0, y0, x1, y1) = fromArea area-  in EM.fromList $ [ (PointXY (x, y), fenceId)+  in EM.fromList $ [ (Point x y, fenceId)                    | x <- [x0-1, x1+1], y <- [y0..y1] ] ++-                   [ (PointXY (x, y), fenceId)+                   [ (Point x y, fenceId)                    | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] --- | Construct a place of the given kind, with the given fence tile.-digPlace :: Place                               -- ^ the place parameters-         -> PlaceKind                           -- ^ the place kind-         -> EM.EnumMap Char (Kind.Id TileKind)  -- ^ the legend-         -> TileMapXY-digPlace Place{..} kr legend =-  let fence = case pfence kr of-        FWall  -> buildFence qsolidFence qarea-        FFloor -> buildFence qhollowFence qarea-        FNone  -> EM.empty-  in EM.union (EM.map (legend EM.!) $ tilePlace qarea kr) fence+-- | Construct a fence around an area, with the given tile group.+buildFenceRnd :: Kind.COps -> Text -> Area -> Rnd TileMapEM+buildFenceRnd Kind.COps{cotile=Kind.Ops{opick}} couterFenceTile area = do+  let (x0, y0, x1, y1) = fromArea area+      fenceIdRnd (xf, yf) = do+        let isCorner x y = x `elem` [x0-1, x1+1] && y `elem` [y0-1, y1+1]+            tileGroup | isCorner xf yf = "basic outer fence"+                      | otherwise = couterFenceTile+        fenceId <- fmap (fromMaybe $ assert `failure` tileGroup)+                   $ opick tileGroup (const True)+        return (Point xf yf, fenceId)+      pointList = [ (x, y) | x <- [x0-1, x1+1], y <- [y0..y1] ]+                  ++ [ (x, y) | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]+  fenceList <- mapM fenceIdRnd pointList+  return $! EM.fromList fenceList  -- TODO: use Text more instead of [Char]? -- | Create a place by tiling patterns. tilePlace :: Area                           -- ^ the area to fill           -> PlaceKind                      -- ^ the place kind to construct-          -> EM.EnumMap PointXY Char+          -> EM.EnumMap Point Char tilePlace area pl@PlaceKind{..} =   let (x0, y0, x1, y1) = fromArea area       xwidth = x1 - x0 + 1@@ -155,33 +174,34 @@         [] -> assert `failure` (area, pl)         l : _ -> T.length l       (dx, dy) = assert (xwidth >= dxcorner && ywidth >= length ptopLeft-                         `blame` (area, pl)) (xwidth, ywidth)-      fromX (x, y) = L.map PointXY $ L.zip [x..] (repeat y)-      fillInterior :: (forall a. Int -> [a] -> [a]) -> [(PointXY, Char)]+                         `blame` (area, pl))+                        (xwidth, ywidth)+      fromX (x2, y2) =+        zipWith (\x y -> Point x y) [x2..] (repeat y2)+      fillInterior :: (forall a. Int -> [a] -> [a]) -> [(Point, Char)]       fillInterior f =-        let tileInterior (y, row) = L.zip (fromX (x0, y)) $ f dx row-            reflected = L.zip [y0..] $ f dy $ map T.unpack ptopLeft-        in L.concatMap tileInterior reflected+        let tileInterior (y, row) = zip (fromX (x0, y)) $ f dx row+            reflected = zip [y0..] $ f dy $ map T.unpack ptopLeft+        in concatMap tileInterior reflected       tileReflect :: Int -> [a] -> [a]       tileReflect d pat =-        let lstart = L.take (d `divUp` 2) pat-            lend   = L.take (d `div`   2) pat-        in lstart ++ L.reverse lend+        let lstart = take (d `divUp` 2) pat+            lend   = take (d `div`   2) pat+        in lstart ++ reverse lend       interior = case pcover of         CAlternate ->           let tile :: Int -> [a] -> [a]               tile _ []  = assert `failure` "nothing to tile" `twith` pl-              tile d pat =-                L.take d (L.cycle $ L.init pat ++ L.init (L.reverse pat))+              tile d pat = take d (cycle $ init pat ++ init (reverse pat))           in fillInterior tile         CStretch ->           let stretch :: Int -> [a] -> [a]               stretch _ []  = assert `failure` "nothing to stretch" `twith` pl-              stretch d pat = tileReflect d (pat ++ L.repeat (L.last pat))+              stretch d pat = tileReflect d (pat ++ repeat (last pat))           in fillInterior stretch         CReflect ->           let reflect :: Int -> [a] -> [a]-              reflect d pat = tileReflect d (L.cycle pat)+              reflect d pat = tileReflect d (cycle pat)           in fillInterior reflect   in EM.fromList interior @@ -200,4 +220,4 @@     qlegend <- get     qsolidFence <- get     qhollowFence <- get-    return Place{..}+    return $! Place{..}
Game/LambdaHack/Server/EffectSem.hs view
@@ -4,9 +4,11 @@   ( -- + Semantics of effects     itemEffect, effectSem     -- * Assorted operations-  , createItems, addHero, spawnMonsters, pickFaction, electLeader, deduceKilled+  , registerItem, createItems, addHero, spawnMonsters+  , electLeader, deduceKilled   ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM@@ -18,7 +20,6 @@ import Data.Text (Text) import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState@@ -37,8 +38,8 @@ import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.Action-import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.Frequency @@ -53,14 +54,16 @@            => ActorId -> ActorId -> Maybe ItemId -> Item            -> m () itemEffect source target miid item = do-  sb <- getsState $ getActorBody source   discoS <- getsServer sdisco   let ik = fromJust $ jkind discoS item       ef = jeffect item   b <- effectSem ef source target   -- The effect is interesting so the item gets identified, if seen-  -- (the item is in source actor's inventory, so his position is given).-  let atomic iid = execCmdAtomic $ DiscoverA (blid sb) (bpos sb) iid ik+  -- (the item is in source actor's inventory, so his position is given,+  -- note that the actor may be moved by the effect; the item is destroyed,+  -- if ever, after the discovery happens).+  postb <- getsState $ getActorBody source+  let atomic iid = execCmdAtomic $ DiscoverA (blid postb) (bpos postb) iid ik   when b $ maybe skip atomic miid  -- | The source actor affects the target actor, with a given effect and power.@@ -84,7 +87,7 @@   Effect.Regeneration p -> effectSem (Effect.Heal p) source target   Effect.Searching p -> effectSearching p source   Effect.Ascend p -> effectAscend p target-  Effect.Escape -> effectEscape target+  Effect.Escape{} -> effectEscape target  -- + Individual semantic functions for effects @@ -166,6 +169,7 @@     execSfxAtomic $ EffectD target Effect.Dominate     -- TODO: Perhaps insert a turn of delay here to allow countermeasures.     electLeader (bfid tb) (blid tb) target+    deduceKilled tb     ais <- getsState $ getActorItem target     execCmdAtomic $ LoseActorA target tb ais     let bNew = tb {bfid = bfid sb}@@ -177,7 +181,6 @@     when (delta > speedZero) $       execCmdAtomic $ HasteActorA target (speedNegate delta)     execCmdAtomic $ LeadFactionA (bfid sb) leaderOld (Just target)-    deduceKilled tb  -- tb (not bNew), because that's how we saw him last     return True  electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()@@ -195,13 +198,15 @@  deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m () deduceKilled body = do-  let fid = bfid body+  cops@Kind.COps{corule} <- getsState scops+  let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule+      fid = bfid body   spawn <- getsState $ isSpawnFaction fid-  summon <- getsState $ isSummonFaction fid-  Config{configFirstDeathEnds} <- getsServer sconfig+  fact <- getsState $ (EM.! fid) . sfactionD+  let horror = isHorrorFact cops fact   mleader <- getsState $ gleader . (EM.! fid) . sfactionD-  when (not spawn && not summon-        && (isNothing mleader || configFirstDeathEnds)) $+  when (not spawn && not horror+        && (isNothing mleader || firstDeathEnds)) $     deduceQuits body $ Status Killed (fromEnum $ blid body) ""  -- ** SummonFriend@@ -242,22 +247,28 @@          -> Char -> Text -> Color.Color -> Time          -> m ActorId addActor mk bfid pos lid hp bsymbol bname bcolor time = do-  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-  let kind = okind mk+  Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops+  Faction{gplayer} <- getsState $ (EM.! bfid) . sfactionD+  DebugModeSer{sdifficultySer} <- getsServer sdebugSer+  nU <- nUI+  -- If no UI factions, the difficulty applies to heroes (for testing).+  let diffHP | playerUI gplayer || nU == 0 && mk == heroKindId coactor =+        (ceiling :: Double -> Int) $ fromIntegral hp * 1.5 ^^ sdifficultySer+             | otherwise = hp+      kind = okind mk       speed = aspeed kind-      m = actorTemplate mk bsymbol bname bcolor speed hp Nothing pos lid time-                        bfid False+      m = actorTemplate mk bsymbol bname bcolor speed diffHP+                        Nothing pos lid time bfid False   acounter <- getsServer sacounter   modifyServer $ \ser -> ser {sacounter = succ acounter}   execCmdAtomic $ CreateActorA acounter m []-  return acounter+  return $! acounter --- TODO: apply this special treatment only to actors with symbol '@'. -- | Create a new hero on the current level, close to the given position. addHero :: (MonadAtomic m, MonadServer m)         => FactionId -> Point -> LevelId -> [(Int, Text)] -> Maybe Int -> Time         -> m ActorId-addHero bfid ppos lid configHeroNames mNumber time = do+addHero bfid ppos lid heroNames mNumber time = do   Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops   Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD   let kId = heroKindId coactor@@ -266,12 +277,14 @@   let freeHeroK = elemIndex Nothing mhs       n = fromMaybe (fromMaybe 100 freeHeroK) mNumber       symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n+      nameFromNumber 0 = "Captain"+      nameFromNumber k = "Hero" <+> tshow k       name | gcolor == Color.BrWhite =-        fromMaybe ("Hero" <+> showT n) $ lookup n configHeroNames-           | otherwise = playerName gplayer <+> "Hero" <+> showT n-      startHP = hp - (hp `div` 5) * min 3 n-  addActor-    kId bfid ppos lid startHP symbol name gcolor time+        fromMaybe (nameFromNumber n) $ lookup n heroNames+           | otherwise =+        playerName gplayer <+> nameFromNumber n+      startHP = hp - (min 10 $ hp `div` 10) * min 5 n+  addActor kId bfid ppos lid startHP symbol name gcolor time  -- ** SpawnMonster @@ -290,8 +303,9 @@       spawnMonsters (take power ps) (blid tm) time fid       return True --- | Spawn monsters of any spawn or summon faction, friendly or not.--- To be used for spontaneous spawning of monsters and for the summon effect.+-- | Spawn non-hero actors of any faction, friendly or not.+-- To be used for initial dungeon population, spontaneous spawning+-- of monsters and for the summon effect. spawnMonsters :: (MonadAtomic m, MonadServer m)               => [Point] -> LevelId -> Time -> FactionId               -> m ()@@ -352,21 +366,31 @@   discoRev <- getsServer sdiscoRev   Level{ldepth, litemFreq} <- getLevel lid   depth <- getsState sdepth+  let container = CFloor lid pos   replicateM_ n $ do     (item, k, _) <- rndToAction                     $ newItem coitem flavour discoRev litemFreq ldepth depth-    itemRev <- getsServer sitemRev-    case HM.lookup item itemRev of-      Just iid ->-        -- TODO: try to avoid this case, to make items more interesting-        execCmdAtomic $ CreateItemA iid item k (CFloor lid pos)-      Nothing -> do-        icounter <- getsServer sicounter-        modifyServer $ \ser ->-          ser { sicounter = succ icounter-              , sitemRev = HM.insert item icounter (sitemRev ser) }-        execCmdAtomic $ CreateItemA icounter item k (CFloor lid pos)+    void $ registerItem item k container True +registerItem :: (MonadAtomic m, MonadServer m)+             => Item -> Int -> Container -> Bool -> m ItemId+registerItem item k container verbose = do+  itemRev <- getsServer sitemRev+  let cmd = if verbose then CreateItemA else SpotItemA+  case HM.lookup item itemRev of+    Just iid -> do+      -- TODO: try to avoid this case for createItems,+      -- to make items more interesting+      execCmdAtomic $ cmd iid item k container+      return iid+    Nothing -> do+      icounter <- getsServer sicounter+      modifyServer $ \ser ->+        ser { sicounter = succ icounter+            , sitemRev = HM.insert item icounter (sitemRev ser) }+      execCmdAtomic $ cmd icounter item k container+      return $! icounter+ -- ** ApplyPerfume  effectApplyPerfume :: MonadAtomic m@@ -399,56 +423,67 @@  effectAscend :: MonadAtomic m => Int -> ActorId -> m Bool effectAscend power target = do-  b <- effLvlGoUp target power-  when b $ execSfxAtomic $ EffectD target $ Effect.Ascend power-  return b+  mfail <- effLvlGoUp target power+  case mfail of+    Nothing -> do+      execSfxAtomic $ EffectD target $ Effect.Ascend power+      return True+    Just failMsg -> do+      b <- getsState $ getActorBody target+      execSfxAtomic $ MsgFidD (bfid b) failMsg+      return False -effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m Bool+effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m (Maybe Msg) effLvlGoUp aid k = do   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 || bproj b1 then-    return False+  (lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon+  if lid2 == lid1 && pos2 == pos1 then+    return $ Just "The effect fizzles: no more levels in this direction."+  else if bproj b1 then+    assert `failure` "projectiles can't exit levels" `twith` (aid, k, b1)   else do+    let switch1 = switchLevels1 ((aid, b1), ais1)+        switch2 = do+          -- Move the actor to where the inhabitant was, if any.+          switchLevels2 lid2 pos2 ((aid, b1), ais1)+          -- Verify only one non-projectile actor on every tile.+          !_ <- getsState $ posToActors pos1 lid1  -- assertion is inside+          !_ <- getsState $ posToActors pos2 lid2  -- assertion is inside+          return Nothing     -- The actor is added to the new level, but there can be other actors     -- at his new position.-    inhabitants <- getsState $ posToActor pos2 lid2+    inhabitants <- getsState $ posToActors 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+      [] -> do+        switch1+        switch2+      ((_, b2), _) : _ -> do         -- Alert about the switch.-        let part2 = partActor b2+        let subjects = map (partActor . snd . fst) inhabitants+            subject = MU.WWandW subjects             verb = "be pushed to another level"-            msg2 = makeSentence [MU.SubjectVerbSg part2 verb]+            msg2 = makeSentence [MU.SubjectVerbSg subject verb]+        -- Only tell one player, even if many actors, because then+        -- they are projectiles, so not too important.         execSfxAtomic $ MsgFidD (bfid b2) msg2         -- Move the actor out of the way.-        switchLevels1 aid+        switch1         -- Move the inhabitant out of the way.-        switchLevels1 aid2+        mapM_ switchLevels1 inhabitants         -- 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+        mapM_ (switchLevels2 lid1 pos1) inhabitants+        switch2 -switchLevels1 :: MonadAtomic m => ActorId -> m ()-switchLevels1 aid = do-  bOld <- getsState $ getActorBody aid-  ais <- getsState $ getActorItem aid+switchLevels1 :: MonadAtomic m => ((ActorId, Actor), [(ItemId, Item)]) -> m ()+switchLevels1 ((aid, bOld), ais) = do   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+  when (not (bproj bOld) && 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.@@ -456,9 +491,9 @@   execCmdAtomic $ LoseActorA aid bOld ais  switchLevels2 :: MonadAtomic m-              => ActorId -> Actor -> [(ItemId, Item)] -> LevelId -> Point+              => LevelId -> Point -> ((ActorId, Actor), [(ItemId, Item)])               -> m ()-switchLevels2 aid bOld ais lidNew posNew = do+switchLevels2 lidNew posNew ((aid, bOld), ais) = do   let lidOld = blid bOld       side = bfid bOld   assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip@@ -471,10 +506,9 @@   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-                  , bpath = Nothing }+                  , boldlid = lidOld }  -- record old level   mleader <- getsState $ gleader . (EM.! side) . sfactionD   -- Materialize the actor at the new location.   -- Onlookers see somebody appear suddenly. The actor himself@@ -483,7 +517,8 @@   -- Changing levels is so important, that the leader changes.   -- 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+  when (not (bproj bOld) && isNothing mleader) $+    -- Trouble, if the actors are of the same faction.     execCmdAtomic $ LeadFactionA side Nothing (Just aid)  -- ** Escape@@ -492,11 +527,12 @@ effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool effectEscape aid = do   -- Obvious effect, nothing announced.+  cops <- getsState scops   b <- getsState $ getActorBody aid   let fid = bfid b-  spawn <- getsState $ isSpawnFaction fid-  summon <- getsState $ isSummonFaction fid-  if spawn || summon || bproj b then return False+  fact <- getsState $ (EM.! fid) . sfactionD+  if not (isHeroFact cops fact) || bproj b then+    return False   else do     deduceQuits b $ Status Escape (fromEnum $ blid b) ""     return True
Game/LambdaHack/Server/Fov.hs view
@@ -2,15 +2,11 @@ -- See <https://github.com/kosmikus/LambdaHack/wiki/Fov-and-los> -- for discussion. module Game.LambdaHack.Server.Fov-  ( dungeonPerception, levelPerception-  , fullscan, FovMode(..)+  ( dungeonPerception, levelPerception, fullscan   ) where -import Control.Arrow (second)-import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.List as L  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState@@ -22,8 +18,8 @@ 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.Content.ActorKind+import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.Fov.Common import qualified Game.LambdaHack.Server.Fov.Digital as Digital@@ -31,36 +27,41 @@ import qualified Game.LambdaHack.Server.Fov.Shadow as Shadow  newtype PerceptionReachable = PerceptionReachable-  { preachable :: ES.EnumSet Point }+    {preachable :: [Point]}   deriving Show  -- | Calculate perception of the level.-levelPerception :: Kind.COps -> State -> FovMode -> FactionId-                -> LevelId -> Level+levelPerception :: Kind.COps -> FovMode -> FactionId+                -> LevelId -> Level -> State                 -> Perception-levelPerception cops@Kind.COps{cotile} s configFov fid lid lvl =-  let hs = actorAssocs (== fid) lid s-      reas = map (second $ computeReachable cops configFov lvl) hs-      lreas = map (preachable . snd) reas-      totalRea = PerceptionReachable $ ES.unions lreas+levelPerception cops@Kind.COps{cotile, coactor=Kind.Ops{okind}}+                configFov fid lid lvl@Level{lxsize, lysize} s =+  let hs = actorNotProjList (== fid) lid s+      cR b = preachable $ computeReachable cops configFov lvl b+      totalReachable = PerceptionReachable $ concatMap cR hs       -- TODO: give actors light sources explicitly or alter vision.-      lights = ES.fromList $ map (bpos . snd) hs-      ptotal = computeVisible cotile totalRea lvl lights-      g = PerceptionVisible . ES.intersection (pvisible ptotal) . preachable-      perActor = EM.map g $ EM.fromList reas  -- reas is not sorted-      psmell = smellFromActors cops s perActor-  in Perception {..}+      pAndVicinity p = p : vicinity lxsize lysize p+      lightsBodies = map (\b -> (pAndVicinity $ bpos b, b)) hs+      light = concat $ map fst lightsBodies+      ptotal = computeVisible cotile totalReachable lvl light+      canSmell b = asmell $ okind $ bkind b+      -- We assume smell FOV radius is always 1, regardless of vision+      -- radius of the actor (if he can see at all).+      psmell = PerceptionVisible $ ES.fromList+               $ concat $ map fst $ filter (canSmell . snd) lightsBodies+  in Perception ptotal psmell  -- | Calculate perception of a faction.-factionPerception :: Kind.COps -> FovMode -> State -> FactionId+factionPerception :: Kind.COps -> FovMode -> FactionId -> State                   -> FactionPers-factionPerception cops configFov s fid =-  EM.mapWithKey (levelPerception cops s configFov fid) $ sdungeon s+factionPerception cops configFov fid s =+  EM.mapWithKey (\lid lvl -> levelPerception cops configFov fid lid lvl s)+                $ sdungeon s  -- | Calculate the perception of the whole dungeon. dungeonPerception :: Kind.COps -> FovMode -> State -> Pers dungeonPerception cops configFov s =-  let f fid _ = factionPerception cops configFov s fid+  let f fid _ = factionPerception cops configFov fid s   in EM.mapWithKey f $ sfactionD s  -- | A position can be directly lit by an ambient shine or a weak, portable@@ -78,24 +79,13 @@ -- there must be a wall in-between. Stray rays indicate doors, -- moving shadows indicate monsters, etc. computeVisible :: Kind.Ops TileKind -> PerceptionReachable-               -> Level -> ES.EnumSet Point -> PerceptionVisible-computeVisible cotile reachable@PerceptionReachable{preachable} lvl lights =-  let isV = isVisible cotile reachable lvl lights-  in PerceptionVisible $ ES.filter isV preachable---- TODO: this is calculated per-faction, not per-actor, but still optimize,--- e.g., by partitioning preachable wrt litDirectly and then running--- isVisible only over one of the parts, depending on which is smaller.-isVisible :: Kind.Ops TileKind -> PerceptionReachable-          -> Level -> ES.EnumSet Point -> Point -> Bool-isVisible cotile PerceptionReachable{preachable}-          lvl@Level{lxsize, lysize} lights pos0 =-  let litDirectly pos = Tile.isLit cotile (lvl `at` pos)-                        || pos `ES.member` lights-      l_and_R pos = litDirectly pos && pos `ES.member` preachable-  in litDirectly pos0 || L.any l_and_R (vicinity lxsize lysize pos0)+               -> Level -> [Point] -> PerceptionVisible+computeVisible cotile PerceptionReachable{preachable} lvl lights =+  let isVisible pos = Tile.isLit cotile (lvl `at` pos)+  in PerceptionVisible $ ES.fromList $ lights ++ filter isVisible preachable --- | Reachable are all fields on an unblocked path from the hero position.+-- | Reachable are all fields on a visually unblocked path+-- from the hero position. computeReachable :: Kind.COps -> FovMode -> Level -> Actor                  -> PerceptionReachable computeReachable Kind.COps{cotile, coactor=Kind.Ops{okind}}@@ -104,7 +94,7 @@       fovMode = if sight then configFov else Blind       ppos = bpos body       scan = fullscan cotile fovMode ppos lvl-  in PerceptionReachable $ ES.fromList scan+  in PerceptionReachable scan  -- | Perform a full scan for a given position. Returns the positions -- that are currently in the field of view. The Field of View@@ -115,65 +105,45 @@          -> Point              -- ^ position of the spectator          -> Level              -- ^ the map that is scanned          -> [Point]-fullscan cotile fovMode spectatorPos Level{lxsize, ltile} = spectatorPos :+fullscan cotile fovMode spectatorPos lvl = spectatorPos :   case fovMode of     Shadow ->-      L.concatMap (\ tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8+      concatMap (\tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8     Permissive ->-      L.concatMap (\ tr -> map tr (Permissive.scan (isCl . tr))) tr4+      concatMap (\tr -> map tr (Permissive.scan (isCl . tr))) tr4     Digital r ->-      L.concatMap (\ tr -> map tr (Digital.scan r (isCl . tr))) tr4+      concatMap (\tr -> map tr (Digital.scan r (isCl . tr))) tr4     Blind ->  -- all actors feel adjacent positions (for easy exploration)       let radiusOne = 1-      in L.concatMap (\ tr -> map tr (Digital.scan radiusOne (isCl . tr))) tr4+      in concatMap (\tr -> map tr (Digital.scan radiusOne (isCl . tr))) tr4  where   isCl :: Point -> Bool-  isCl = Tile.isClear cotile . (ltile Kind.!)+  isCl = Tile.isClear cotile . (lvl `at`) -  trV xy = shift spectatorPos $ toVector lxsize $ VectorXY xy+  -- This function is cheap, so no problem it's called twice+  -- for each point: once with @isCl@, once via @concatMap@.+  trV :: X -> Y -> Point+  {-# INLINE trV #-}+  trV x y = shift spectatorPos $ Vector x y    -- | The translation, rotation and symmetry functions for octants.   tr8 :: [(Distance, Progress) -> Point]   tr8 =-    [ \ (p, d) -> trV (  p,   d)-    , \ (p, d) -> trV (- p,   d)-    , \ (p, d) -> trV (  p, - d)-    , \ (p, d) -> trV (- p, - d)-    , \ (p, d) -> trV (  d,   p)-    , \ (p, d) -> trV (- d,   p)-    , \ (p, d) -> trV (  d, - p)-    , \ (p, d) -> trV (- d, - p)+    [ \(p, d) -> trV   p    d+    , \(p, d) -> trV (-p)   d+    , \(p, d) -> trV   p  (-d)+    , \(p, d) -> trV (-p) (-d)+    , \(p, d) -> trV   d    p+    , \(p, d) -> trV (-d)   p+    , \(p, d) -> trV   d  (-p)+    , \(p, d) -> trV (-d) (-p)     ]    -- | The translation and rotation functions for quadrants.   tr4 :: [Bump -> Point]   tr4 =-    [ \ (B(x, y)) -> trV (  x, - y)  -- quadrant I-    , \ (B(x, y)) -> trV (  y,   x)  -- II (we rotate counter-clockwise)-    , \ (B(x, y)) -> trV (- x,   y)  -- III-    , \ (B(x, y)) -> trV (- y, - x)  -- IV+    [ \B{..} -> trV   bx  (-by)  -- quadrant I+    , \B{..} -> trV   by    bx   -- II (we rotate counter-clockwise)+    , \B{..} -> trV (-bx)   by   -- III+    , \B{..} -> trV (-by) (-bx)  -- IV     ]---- TODO: should Blind really be a FovMode, or a modifier? Let's decide--- 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-  deriving (Show, Read)--instance Binary FovMode where-  put Shadow      = putWord8 0-  put Permissive  = putWord8 1-  put (Digital r) = putWord8 2 >> put r-  put Blind       = putWord8 3-  get = do-    tag <- getWord8-    case tag of-      0 -> return Shadow-      1 -> return Permissive-      2 -> fmap Digital get-      3 -> return Blind-      _ -> fail "no parse (FovMode)"
Game/LambdaHack/Server/Fov/Common.hs view
@@ -7,14 +7,12 @@     -- * Scanning coordinate system   , Bump(..)     -- * Geometry in system @Bump@-  , Line, ConvexHull, Edge, EdgeInterval+  , Line(..), ConvexHull, Edge, EdgeInterval     -- * Assorted minor operations   , maximal, steeper, addHull   ) where -import qualified Data.List as L--import Game.LambdaHack.Common.PointXY+import Data.List  -- | Distance from the (0, 0) point where FOV originates. type Distance = Int@@ -28,11 +26,16 @@ -- The special coordinates are written using the standard mathematical -- coordinate setup, where quadrant I, with x and y positive, -- is on the upper right.-newtype Bump = B (X, Y)-  deriving (Show)+data Bump = B+  { bx :: !Int+  , by :: !Int+  }+  deriving Show  -- | Straight line between points.-type Line         = (Bump, Bump)+data Line = Line !Bump !Bump+  deriving Show+ -- | Convex hull represented as a list of points. type ConvexHull   = [Bump] -- | An edge (comprising of a line and a convex hull)@@ -44,14 +47,16 @@ -- | Maximal element of a non-empty list. Prefers elements from the rear, -- which is essential for PFOV, to avoid ill-defined lines. maximal :: (a -> a -> Bool) -> [a] -> a-maximal gte = L.foldl1' (\ acc e -> if gte e acc then e else acc)+{-# INLINE maximal #-}+maximal gte = foldl1' (\acc e -> if gte e acc then e else acc)  -- | Check if the line from the second point to the first is more steep -- than the line from the third point to the first. This is related -- to the formal notion of gradient (or angle), but hacked wrt signs -- to work fast in this particular setup. Returns True for ill-defined lines. steeper :: Bump -> Bump -> Bump -> Bool-steeper (B(xf, yf)) (B(x1, y1)) (B(x2, y2)) =+{-# INLINE steeper #-}+steeper (B xf yf) (B x1 y1) (B x2 y2) =   (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1)  -- | Extends a convex hull of bumps with a new bump. Nothing needs to be done@@ -61,6 +66,7 @@         -> Bump                    -- ^ a new bump to consider         -> ConvexHull  -- ^ a convex hull of bumps represented as a list         -> ConvexHull+{-# INLINE addHull #-} addHull gte new = (new :) . go  where   go (a:b:cs) | gte a b = go (b:cs)
Game/LambdaHack/Server/Fov/Digital.hs view
@@ -5,9 +5,10 @@   ( scan, dline, dsteeper, intersect, debugSteeper, debugLine   ) where +import Control.Exception.Assert.Sugar+ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server.Fov.Common-import Control.Exception.Assert.Sugar  -- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0), -- within the given sight range.@@ -16,10 +17,13 @@      -> [Bump] scan r isClear =   -- The scanned area is a square, which is a sphere in the chessboard metric.-  dscan 1 (((B(1, 0), B(-r, r)), [B(0, 0)]), ((B(0, 0), B(r+1, r)), [B(1, 0)]))+  dscan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0])+          , (Line (B 0 0) (B (r+1) r), [B 1 0]) )  where   dscan :: Distance -> EdgeInterval -> [Bump]-  dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) =+  dscan d ( s0@(sl{-shallow line-}, sHull0)+          , e@(el{-steep line-}, eHull) ) =+     let ps0 = let (n, k) = intersect sl d  -- minimal progress to consider               in n `div` k         pe = let (n, k) = intersect el d   -- maximal progress to consider@@ -28,49 +32,53 @@                -- so if its intersection with the line of diagonals is only                -- at a corner, choose the diamond leading to a smaller view.              in -1 + n `divUp` k-        inside = [B(p, d) | p <- [ps0..pe]]+        inside = [B p d | p <- [ps0..pe]]         outside           | d >= r = []-          | isClear (B(ps0, d)) = mscan (Just s0) (ps0+1) pe  -- start in light-          | otherwise = mscan Nothing (ps0+1) pe              -- start in shadow+          | isClear (B ps0 d) = mscanVisible s0 (ps0+1)  -- start visible+          | otherwise = mscanShadowed (ps0+1)            -- start in shadow++        -- We're in a visible interval.+        mscanVisible :: Edge -> Progress -> [Bump]+        mscanVisible s@(_, sHull) ps+          | ps > pe = dscan (d+1) (s, e)       -- reached end, scan next+          | not $ isClear steepBump =          -- entering shadow+              mscanShadowed (ps+1)+              ++ dscan (d+1) (s, (dline nep steepBump, neHull))+          | otherwise = mscanVisible s (ps+1)  -- continue in visible area+         where+          steepBump = B ps d+          gte = dsteeper steepBump+          nep = maximal gte sHull+          neHull = addHull gte steepBump eHull++        -- We're in a shadowed interval.+        mscanShadowed :: Progress -> [Bump]+        mscanShadowed ps+          | ps > pe = []                       -- reached end while in shadow+          | isClear shallowBump =              -- moving out of shadow+              mscanVisible (dline nsp shallowBump, nsHull) (ps+1)+          | otherwise = mscanShadowed (ps+1)   -- continue in shadow+         where+          shallowBump = B ps d+          gte = flip $ dsteeper shallowBump+          nsp = maximal gte eHull+          nsHull = addHull gte shallowBump sHull0+     in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e,ps0,pe)) $        inside ++ outside-   where-    -- The current state of a scan is kept in @Maybe Edge@.-    -- If it's the @Just@ case, we're in a visible interval. If @Nothing@,-    -- we're in a shadowed interval.-    mscan :: Maybe Edge -> Progress -> Progress -> [Bump]-    mscan (Just s@(_, sBumps)) ps pe-      | ps > pe = dscan (d+1) (s, e)          -- reached end, scan next-      | not $ isClear steepBump =             -- entering shadow-          mscan Nothing (ps+1) pe-          ++ dscan (d+1) (s, (dline nep steepBump, neBumps))-      | otherwise = mscan (Just s) (ps+1) pe  -- continue in light-     where-      steepBump = B(ps, d)-      gte = dsteeper steepBump-      nep = maximal gte sBumps-      neBumps = addHull gte steepBump eBumps -    mscan Nothing ps pe-      | ps > pe = []                          -- reached end while in shadow-      | isClear shallowBump =                 -- moving out of shadow-          mscan (Just (dline nsp shallowBump, nsBumps)) (ps+1) pe-      | otherwise = mscan Nothing (ps+1) pe   -- continue in shadow-     where-      shallowBump = B(ps, d)-      gte = flip $ dsteeper shallowBump-      nsp = maximal gte eBumps-      nsBumps = addHull gte shallowBump sBumps0- -- | Create a line from two points. Debug: check if well-defined. dline :: Bump -> Bump -> Line+{-# INLINE dline #-} dline p1 p2 =-  assert (uncurry blame $ debugLine (p1, p2)) (p1, p2)+  let line = Line p1 p2+  in assert (uncurry blame $ debugLine line) line  -- | Compare steepness of @(p1, f)@ and @(p2, f)@. -- Debug: Verify that the results of 2 independent checks are equal. dsteeper :: Bump ->  Bump -> Bump -> Bool+{-# INLINE dsteeper #-} dsteeper f p1 p2 =   assert (res == debugSteeper f p1 p2) res  where res = steeper f p1 p2@@ -79,7 +87,8 @@ -- a given line and the line of diagonals of diamonds at distance -- @d@ from (0, 0). intersect :: Line -> Distance -> (Int, Int)-intersect (B(x, y), B(xf, yf)) d =+{-# INLINE intersect #-}+intersect (Line (B x y) (B xf yf)) d =   assert (allB (>= 0) [y, yf])     ((d - y)*(xf - x) + x*(yf - y), yf - y) {-@@ -115,15 +124,17 @@  -- | Debug: calculate steeper for DFOV in another way and compare results. debugSteeper :: Bump -> Bump -> Bump -> Bool-debugSteeper f@(B(_xf, yf)) p1@(B(_x1, y1)) p2@(B(_x2, y2)) =+{-# INLINE debugSteeper #-}+debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) =   assert (allB (>= 0) [yf, y1, y2]) $-  let (n1, k1) = intersect (p1, f) 0-      (n2, k2) = intersect (p2, f) 0+  let (n1, k1) = intersect (Line p1 f) 0+      (n2, k2) = intersect (Line p2 f) 0   in n1 * k2 >= k1 * n2  -- | Debug: check if a view border line for DFOV is legal. debugLine :: Line -> (Bool, String)-debugLine line@(B(x1, y1), B(x2, y2))+{-# INLINE debugLine #-}+debugLine line@(Line (B x1 y1) (B x2 y2))   | not (allB (>= 0) [y1, y2]) =       (False, "negative coordinates: " ++ show line)   | y1 == y2 && x1 == x2 =
Game/LambdaHack/Server/Fov/Permissive.hs view
@@ -7,9 +7,10 @@   ( scan, dline, dsteeper, intersect, debugSteeper, debugLine   ) where +import Control.Exception.Assert.Sugar+ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server.Fov.Common-import Control.Exception.Assert.Sugar  -- TODO: Scanning squares on horizontal lines in octants, not squares -- on diagonals in quadrants, may be much faster and a bit simpler.@@ -20,10 +21,12 @@ scan :: (Bump -> Bool)  -- ^ clear tile predicate      -> [Bump] scan isClear =-  dscan 1 (((B(0, 1), B(999, 0)), [B(1, 0)]), ((B(1, 0), B(0, 999)), [B(0, 1)]))+  dscan 1 ( (Line (B 0 1) (B 999 0), [B 1 0])+          , (Line (B 1 0) (B 0 999), [B 0 1]) )  where   dscan :: Distance -> EdgeInterval -> [Bump]-  dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) =+  dscan d ( s0@(sl{-shallow line-}, sHull0)+          , e@(el{-steep line-}, eHull) ) =     assert (d >= 0 && pe + 1 >= ps0 && ps0 >= 0             `blame` (d,s0,e,ps0,pe)) $     if illegal then [] else inside ++ outside@@ -36,46 +39,47 @@     -- A single ray from an extremity produces non-permissive digital lines.     illegal  = let (n, k) = intersect sl 0                in ns*ke == ne*ks && (n `elem` [0, k])-    pd2bump     (p, di) = B(di - p    , p)-    bottomRight (p, di) = B(di - p + 1, p)+    pd2bump     (p, di) = B (di - p) p+    bottomRight (p, di) = B (di - p + 1) p      inside = [pd2bump (p, d) | p <- [ps0..pe]]     outside-      | isClear (pd2bump (ps0, d)) = mscan (Just s0) ps0  -- start in light-      | ps0 == ns `divUp` ks = mscan (Just s0) ps0        -- start in a corner-      | otherwise = mscan Nothing (ps0+1)                 -- start in mid-wall+      | isClear (pd2bump (ps0, d)) = mscanVisible s0 ps0  -- start visible+      | ps0 == ns `divUp` ks = mscanVisible s0 ps0        -- start in a corner+      | otherwise = mscanShadowed (ps0+1)                 -- start in mid-wall -    -- The current state of a scan is kept in @Maybe Edge@.-    -- If it's the @Just@ case, we're in a visible interval. If @Nothing@,-    -- we're in a shadowed interval.-    mscan :: Maybe Edge -> Progress -> [Bump]-    mscan (Just s@(_, sBumps)) ps+    -- We're in a visible interval.+    mscanVisible :: Edge -> Progress -> [Bump]+    mscanVisible s@(_, sHull) ps       | ps > pe = dscan (d+1) (s, e)           -- reached end, scan next       | not $ isClear (pd2bump (ps, d)) =      -- enter shadow, steep bump           let steepBump = bottomRight (ps, d)               gte = flip $ dsteeper steepBump-              -- sBumps may contain steepBump, but maximal will ignore it-              nep = maximal gte sBumps-              neBumps = addHull gte steepBump eBumps-          in mscan Nothing (ps+1)-             ++ dscan (d+1) (s, (dline nep steepBump, neBumps))-      | otherwise = mscan (Just s) (ps+1)      -- continue in light+              -- sHull may contain steepBump, but maximal will ignore it+              nep = maximal gte sHull+              neHull = addHull gte steepBump eHull+          in mscanShadowed (ps+1)+             ++ dscan (d+1) (s, (dline nep steepBump, neHull))+      | otherwise = mscanVisible s (ps+1)      -- continue in visible area -    mscan Nothing ps+    -- we're in a shadowed interval.+    mscanShadowed :: Progress -> [Bump]+    mscanShadowed ps       | ps > ne `div` ke = []                  -- reached absolute end       | otherwise =                            -- out of shadow, shallow bump-          -- the light can be just through a corner of diagonal walls+          -- the ray can just pass through a corner of diagonal walls           -- and the recursive call verifies that at the same ps coordinate           let shallowBump = bottomRight (ps, d)               gte = dsteeper shallowBump-              nsp = maximal gte eBumps-              nsBumps = addHull gte shallowBump sBumps0-          in mscan (Just (dline nsp shallowBump, nsBumps)) ps+              nsp = maximal gte eHull+              nsHull = addHull gte shallowBump sHull0+          in mscanVisible (dline nsp shallowBump, nsHull) ps  -- | Create a line from two points. Debug: check if well-defined. dline :: Bump -> Bump -> Line dline p1 p2 =-  assert (uncurry blame $ debugLine (p1, p2)) (p1, p2)+  let line = Line p1 p2+  in assert (uncurry blame $ debugLine line) line  -- | Compare steepness of @(p1, f)@ and @(p2, f)@. -- Debug: Verify that the results of 2 independent checks are equal.@@ -88,7 +92,7 @@ -- a given line and the line of diagonals of squares at distance -- @d@ from (0, 0). intersect :: Line -> Distance -> (Int, Int)-intersect (B(x, y), B(xf, yf)) d =+intersect (Line (B x y) (B xf yf)) d =   assert (allB (>= 0) [x, y, xf, yf])     ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y)) {-@@ -125,15 +129,15 @@  -- | Debug: calculate steeper for PFOV in another way and compare results. debugSteeper :: Bump -> Bump -> Bump -> Bool-debugSteeper f@(B(xf, yf)) p1@(B(x1, y1)) p2@(B(x2, y2)) =+debugSteeper f@(B xf yf) p1@(B x1 y1) p2@(B x2 y2) =   assert (allB (>= 0) [xf, yf, x1, y1, x2, y2]) $-  let (n1, k1) = intersect (p1, f) 0-      (n2, k2) = intersect (p2, f) 0+  let (n1, k1) = intersect (Line p1 f) 0+      (n2, k2) = intersect (Line p2 f) 0   in n1 * k2 <= k1 * n2  -- | Debug: checks postconditions of borderLine. debugLine :: Line -> (Bool, String)-debugLine line@(B(x1, y1), B(x2, y2))+debugLine line@(Line (B x1 y1) (B x2 y2))   | not (allB (>= 0) [x1, y1, x2, y2]) =       (False, "negative coordinates: " ++ show line)   | y1 == y2 && x1 == x2 =
Game/LambdaHack/Server/Fov/Shadow.hs view
@@ -4,10 +4,10 @@ -- The main advantage of the algorithm is that it's very simple and fast. module Game.LambdaHack.Server.Fov.Shadow (SBump, Interval, scan) where +import Control.Exception.Assert.Sugar import Data.Ratio  import Game.LambdaHack.Server.Fov.Common-import Control.Exception.Assert.Sugar  {- Field Of View
Game/LambdaHack/Server/LoopAction.hs view
@@ -3,16 +3,15 @@ module Game.LambdaHack.Server.LoopAction (loopSer) where  import Control.Arrow ((&&&))+import Control.Exception.Assert.Sugar 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 Data.Text (Text) -import Control.Exception.Assert.Sugar-import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState@@ -31,16 +30,16 @@ 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.Content.RuleKind import Game.LambdaHack.Frontend import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI)-import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.EffectSem import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ServerSem import Game.LambdaHack.Server.StartAction import Game.LambdaHack.Server.State+import Game.LambdaHack.Utils.Frequency  -- | Start a game session. Loop, communicating with clients. loopSer :: (MonadAtomic m, MonadConnServer m)@@ -48,7 +47,7 @@         -> (CmdSer -> m Bool)         -> (FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer             -> IO ())-        -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime+        -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer             -> IO ())         -> Kind.COps         -> m ()@@ -61,7 +60,7 @@       let setPreviousCops = const cops       execCmdAtomic $ ResumeServerA $ updateCOps setPreviousCops sRaw       putServer ser-      sdebugNxt <- initDebug sdebug+      sdebugNxt <- initDebug cops sdebug       modifyServer $ \ser2 -> ser2 {sdebugNxt}       applyDebug       updateConn executorUI executorAI@@ -72,21 +71,22 @@       let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)       -- @sRaw@ is correct here, because none of the above changes State.       execCmdAtomic $ ResumeServerA $ updateCOps setCurrentCops sRaw-      initPer     _ -> do  -- Starting a new game.       -- Set up commandline debug mode       let mrandom = case restored of             Just (_, ser) -> Just $ srandom ser             Nothing -> Nothing       s <- gameReset cops sdebug mrandom-      sdebugNxt <- initDebug sdebug-      modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt}+      sdebugNxt <- initDebug cops sdebug+      let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}+      modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs+                                 , sdebugSer = debugBarRngs }       let speedup = speedupCOps (sallClear sdebugNxt)       execCmdAtomic $ RestartServerA $ updateCOps speedup s       updateConn executorUI executorAI       initPer       reinitGame-      when (sdumpConfig sdebug) $ void $ dumpCfg+  when (sdumpInitRngs sdebug) $ dumpRngs   resetSessionStart   -- Start a clip (a part of a turn for which one or more frames   -- will be generated). Do whatever has to be done@@ -101,7 +101,7 @@                Just leader -> do                   b <- getsState $ getActorBody leader                   return $ Just $ blid b-               _ -> return Nothing+               Nothing -> return Nothing         factionD <- getsState sfactionD         marenas <- mapM factionArena $ EM.elems factionD         let arenas = ES.toList $ ES.fromList $ catMaybes marenas@@ -118,34 +118,23 @@           when continue loop   loop -initDebug :: MonadServer m => DebugModeSer -> m DebugModeSer-initDebug sdebugSer = do-  sconfig <- getsServer sconfig-  return $+initDebug :: MonadActionRO m => Kind.COps -> DebugModeSer -> m DebugModeSer+initDebug Kind.COps{corule} sdebugSer = do+  let stdRuleset = Kind.stdRuleset corule+  return $!     (\dbg -> dbg {sfovMode =-        sfovMode dbg `mplus` Just (configFovMode sconfig)}) .+        sfovMode dbg `mplus` Just (rfovMode stdRuleset)}) .     (\dbg -> dbg {ssavePrefixSer =-        ssavePrefixSer dbg `mplus` Just (configSavePrefix sconfig)})+        ssavePrefixSer dbg `mplus` Just (rsavePrefix stdRuleset)})     $ 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-  saveServer- endClip :: (MonadAtomic m, MonadServer m, MonadConnServer m)         => [LevelId] -> m Bool endClip arenas = do+  Kind.COps{corule} <- getsState scops+  let stdRuleset = Kind.stdRuleset corule+      saveBkpClips = rsaveBkpClips stdRuleset+      leadLevelClips = rleadLevelClips stdRuleset   -- 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@@ -155,15 +144,15 @@   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-      clipMod = clipN `mod` cinT+      clipInTurn = let r = timeTurn `timeFit` timeClip+                   in assert (r > 2) r+      clipMod = clipN `mod` clipInTurn   bkpSave <- getsServer sbkpSave-  when (bkpSave || clipN `mod` configSaveBkpClips == 0) $ do+  when (bkpSave || clipN `mod` saveBkpClips == 0) $ do     modifyServer $ \ser -> ser {sbkpSave = False}-    saveBkpAll+    saveBkpAll False+  when (clipN `mod` leadLevelClips == 0) leadLevelFlip   -- 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.@@ -171,12 +160,13 @@     arena <- rndToAction $ oneOf arenas     regenerateLevelHP arena     generateMonster arena-    sstopAfter <- getsServer $ sstopAfter . sdebugSer-    case sstopAfter of+    stopAfter <- getsServer $ sstopAfter . sdebugSer+    case stopAfter of       Nothing -> return True-      Just stopAfter -> do-        exit <- elapsedSessionTimeGT stopAfter+      Just stopA -> do+        exit <- elapsedSessionTimeGT stopA         if exit then do+          tellAllClipPS           saveAndExit           return False  -- don't re-enter the game loop         else return True@@ -192,7 +182,6 @@              -> LevelId              -> m () handleActors cmdSerSem lid = do-  Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops   time <- getsState $ getLocalTime lid  -- the end of this clip, inclusive   Level{lprio} <- getLevel lid   quit <- getsServer squit@@ -212,28 +201,34 @@   case mnext of     _ | quit -> return ()     Nothing -> return ()-    Just (aid, b) | bproj b && bhp b < 0 -> do+    Just (aid, b) | bhp b < 0 && bproj b -> do       -- A projectile hits an actor. The carried item is destroyed.-      -- TODO: perhaps don't destroy if no effect (NoEffect).-      ais <- getsState $ getActorItem aid-      execCmdAtomic $ DestroyActorA aid b ais+      -- TODO: perhaps don't destroy if no effect (NoEffect),+      -- to help testing items. But OTOH, we want most items to have+      -- some effect, even silly, for flavour. Anyway, if the silly+      -- effect identifies an item, the hit is not wasted, so this makes sense.+      dieSer aid b True       -- The attack animation for the projectile hit subsumes @DisplayPushD@,       -- so not sending an extra @DisplayPushD@ here.       handleActors cmdSerSem lid-    Just (aid, b) | bhp b <= 0 && not (bproj b)-                    || maybe False null (bpath b) -> do-      -- An actor (projectile or not) ceases to exist.-      -- Items drop to the ground and possibly a new leader is elected.-      dieSer aid-      -- If it's a death, not a projectile drop, the death animation-      -- subsumes @DisplayPushD@, so not sending it here. ProjectileProjectile-      -- destruction is not important enough for an extra @DisplayPushD@.+    Just (aid, b) | maybe False null (btrajectory b) -> do+      assert (bproj b) skip+      execSfxAtomic $ DisplayPushD (bfid b)  -- show last position before drop+      -- A projectile drops to the ground due to obstacles or range.+      dieSer aid b False       handleActors cmdSerSem lid+    Just (aid, b) | bhp b <= 0 && not (bproj b) -> do+      -- An actor dies. Items drop to the ground+      -- and possibly a new leader is elected.+      dieSer aid b False+      -- The death animation subsumes @DisplayPushD@, so not sending it here.+      handleActors cmdSerSem lid     Just (aid, body) -> do       let side = bfid body           fact = factionD EM.! side           mleader = gleader fact-          queryUI | Just aid == mleader = not $ playerAiLeader $ gplayer fact+          aidIsLeader = mleader == Just aid+          queryUI | aidIsLeader = not $ playerAiLeader $ gplayer fact                   | otherwise = not $ playerAiOther $ gplayer fact           switchLeader cmdS = do             -- TODO: check that the command is legal first, report and reject,@@ -245,9 +240,11 @@                   then -- Only a leader can change his faction's leader                        -- before the action is performed (e.g., via AI                        -- switching leaders). Then, the action can change-                       -- the leader again (e.g., via using stairs).-                       assert (mleader == Just aid && not (bproj bPre)-                               `blame` (aid, aidNew, bPre, cmdS, fact))+                       -- the leader again (e.g., via killing the old leader).+                       assert (aidIsLeader+                               && not (bproj bPre)+                               && not (isSpawnFact fact)+                               `blame` (aid, body, aidNew, bPre, cmdS, fact))                          [LeadFactionA side mleader (Just aidNew)]                   else []             mapM_ execCmdAtomic leadAtoms@@ -255,6 +252,12 @@                     `blame` "client tries to move other faction actors"                     `twith` (bPre, side)) skip             return (aidNew, bPre)+          setBWait (CmdTakeTimeSer WaitSer{}) aidNew bPre = do+            let fromWait = bwait bPre+            unless fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait True+          setBWait _ aidNew bPre = do+            let fromWait = bwait bPre+            when fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait False           extraFrames bPre = do             -- Generate extra frames if the actor has already moved during             -- this clip, so his multiple moves would be collapsed@@ -265,7 +268,22 @@                 lastSingleMove = timeAddFromSpeed bPre previousClipEnd             when (btime bPre > lastSingleMove) $               broadcastSfxAtomic DisplayPushD-      if queryUI then do+      if bproj body then do  -- TODO: perhaps check Track, not bproj+        execSfxAtomic $ DisplayPushD side+        let cmdS = CmdTakeTimeSer $ SetTrajectorySer aid+        timed <- cmdSerSem cmdS+        assert timed skip+        b <- getsState $ getActorBody aid+        -- Colliding with a wall or actor doesn't take time, because+        -- the projectile does not move (the move is blocked).+        -- Not advancing time forces dead projectiles to be destroyed ASAP.+        -- Otherwise it would be displayed in the same place twice.+        -- If ever needed this can be implemented properly by moving+        -- SetTrajectorySer out of CmdTakeTimeSer.+        unless (bhp b < 0 || maybe False null (btrajectory b)) $ do+          advanceTime aid+          extraFrames b+      else if queryUI then do         -- The client always displays a frame in this case.         cmdS <- sendQueryUI side aid         (aidNew, bPre) <- switchLeader cmdS@@ -275,6 +293,7 @@               $ MsgFidD side "You strain, fumble and faint from the exertion."             return False           else cmdSerSem cmdS+        setBWait cmdS aidNew bPre         -- 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@@ -292,54 +311,112 @@         -- 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+        -- is a leader (which happens when a UI client is fully+        -- computer-controlled). We could record history more often,+        -- to avoid long reports, but we'd have to add -more- prompts.+        let mainUIactor = playerUI (gplayer fact) && aidIsLeader+        when mainUIactor $ execSfxAtomic $ RecordHistoryD side+        cmdTimed <- sendQueryAI side aid+        let cmdS = CmdTakeTimeSer cmdTimed         (aidNew, bPre) <- switchLeader cmdS         assert (not (bhp bPre <= 0 && not (bproj bPre))                 `blame` "AI switches to an incapacitated actor"                 `twith` (cmdS, bPre, side)) skip-        void $ cmdSerSem cmdS+        timed <- cmdSerSem cmdS+        assert timed skip+        setBWait cmdS aidNew bPre         -- AI always takes time and so doesn't loop.         advanceTime aidNew         extraFrames bPre       handleActors cmdSerSem lid -dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-dieSer aid = do  -- TODO: explode if a projectile holding a potion-  body <- getsState $ getActorBody aid+dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m ()+dieSer aid b hit = do   -- TODO: clients don't see the death of their last standing actor;   --       modify Draw.hs and Client.hs to handle that-  electLeader (bfid body) (blid body) aid-  dropAllItems aid body-  execCmdAtomic $ DestroyActorA aid body {bbag = EM.empty} []-  deduceKilled body+  if bproj b then do+    dropAllItems aid b hit+    b2 <- getsState $ getActorBody aid+    execCmdAtomic $ DestroyActorA aid b2 []+  else do+    electLeader (bfid b) (blid b) aid+    deduceKilled b+    dropAllItems aid b False+    b2 <- getsState $ getActorBody aid+    execCmdAtomic $ DestroyActorA aid b2 [] --- | Drop all actor's items.-dropAllItems :: MonadAtomic m => ActorId -> Actor -> m ()-dropAllItems aid b = do-  let f iid k = execCmdAtomic-                $ MoveItemA iid k (actorContainer aid (binv b) iid)-                                  (CFloor (blid b) (bpos b))+-- | Drop all actor's items. If the actor hits another actor and this+-- collision results in all item being dropped, all items are destroyed.+-- If the actor does not hit, but dies, only fragile items are destroyed+-- and only if the actor was a projectile (and so died by dropping+-- to the ground due to exceeded range or bumping off an obstacle).+dropAllItems :: (MonadAtomic m, MonadServer m)+             => ActorId -> Actor -> Bool -> m ()+dropAllItems aid b hit = do+  Kind.COps{coitem} <- getsState scops+  discoS <- getsServer sdisco+  let isDestroyed item = hit || bproj b && isFragile coitem discoS item+      f iid k = do+        let container = actorContainer aid (binv b) iid+        item <- getsState $ getItemBody iid+        if isDestroyed item then+          case isExplosive coitem discoS item of+            Nothing -> execCmdAtomic $ DestroyItemA iid item k container+            Just cgroup -> do+              let ik = fromJust $ jkind discoS item+              execCmdAtomic $ DiscoverA (blid b) (bpos b) iid ik+              execCmdAtomic $ DestroyItemA iid item k container+              explodeItem aid b container cgroup+        else+          execCmdAtomic $ MoveItemA iid k container (CFloor (blid b) (bpos b))   mapActorItems_ f b +explodeItem :: (MonadAtomic m, MonadServer m)+            => ActorId -> Actor -> Container -> Text -> m ()+explodeItem aid b container cgroup = do+  Kind.COps{coitem} <- getsState scops+  flavour <- getsServer sflavour+  discoRev <- getsServer sdiscoRev+  Level{ldepth} <- getLevel $ blid b+  depth <- getsState sdepth+  let itemFreq = toFreq "shrapnel group" [(1, cgroup)]+  (item, n1, _) <- rndToAction+                   $ newItem coitem flavour discoRev itemFreq ldepth depth+  iid <- registerItem item n1 container False+  let Point x y = bpos b+      projectN n = replicateM_ n $ do+        tpxy <- rndToAction $ do+          border <- randomR (1, 4)+          -- We pick a point at the border, not inside, to have a uniform+          -- distribution for the points the line goes through at each distance+          -- from the source. Otherwise, e.g., the points on cardinal+          -- and diagonal lines from the source would be more common.+          case border :: Int of+            1 -> fmap (Point (x - 10)) $ randomR (y - 10, y + 10)+            2 -> fmap (Point (x + 10)) $ randomR (y - 10, y + 10)+            3 -> fmap (flip Point (y - 10)) $ randomR (x - 10, x + 10)+            4 -> fmap (flip Point (y + 10)) $ randomR (x - 10, x + 10)+            _ -> assert `failure` border+        let eps = px tpxy + py tpxy+        mfail <- projectFail aid tpxy eps iid container True+        case mfail of+          Nothing -> return ()+          Just ProjectBlockTerrain -> return ()+          Just failMsg -> execFailure aid failMsg+  projectN n1+  bag2 <- getsState $ bbag . getActorBody aid+  let mn2 = EM.lookup iid bag2+  maybe skip projectN mn2  -- assume all shrapnels bounce off obstacles once+  bag3 <- getsState $ bbag . getActorBody aid+  let mn3 = EM.lookup iid bag3+  maybe skip (\k -> execCmdAtomic $ LoseItemA iid item k container) mn3+ -- | Advance the move time for the given actor. advanceTime :: MonadAtomic m => ActorId -> m () advanceTime aid = do   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 t = ticksPerMeter $ bspeed b-    execCmdAtomic $ AgeActorA aid t+  let t = ticksPerMeter $ bspeed b+  execCmdAtomic $ AgeActorA aid t  -- | Generate a monster, possibly. generateMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()@@ -352,9 +429,15 @@       spawns = actorNotProjList f lid s   depth <- getsState sdepth   rc <- rndToAction $ monsterGenChance ldepth depth (length spawns)+  factionD <- getsState sfactionD   when rc $ do     time <- getsState $ getLocalTime lid-    mfid <- pickFaction "spawn" (const True)+    let freq = toFreq "spawn"+               $ map (\(fid, fact) -> (playerSpawn $ gplayer fact, fid))+               $ EM.assocs factionD+    mfid <- if nullFreq freq then+              return Nothing+            else fmap Just $ rndToAction $ frequency freq     case mfid of       Nothing -> return ()  -- no faction spawns       Just fid -> do@@ -373,9 +456,9 @@       as = actorList (const True) lid s       isLit = Tile.isLit cotile       distantAtLeast d p _ =-        all (\b -> chessDist lxsize (bpos b) p > d) inhabitants+        all (\b -> chessDist (bpos b) p > d) inhabitants   findPosTry 40 ltile-    ( \p t -> Tile.hasFeature cotile F.Walkable t+    ( \p t -> Tile.isWalkable cotile t               && unoccupied as p)     [ \_ t -> not (isLit t)  -- no such tiles on some maps     , distantAtLeast factionDist@@ -394,7 +477,7 @@ -- thing, but immediately (and destroy the item). -- | Possibly regenerate HP for all actors on the current level. ----- We really want leader selection to be a purely UI distinction,+-- We really want leader picking to be a purely UI distinction, -- so all actors need to regenerate, not just the leaders. -- Actors on frozen levels don't regenerate. This prevents cheating -- via sending an actor to a safe level and letting him regenerate there.@@ -418,10 +501,54 @@               || bhp m <= 0            then Nothing            else Just a-  toRegen <--    getsState $ mapMaybe approve . actorNotProjAssocs (const True) lid+  toRegen <- getsState $ mapMaybe approve . actorNotProjAssocs (const True) lid   mapM_ (\aid -> execCmdAtomic $ HealActorA aid 1) toRegen +leadLevelFlip :: (MonadAtomic m, MonadServer m) => m ()+leadLevelFlip = do+  Kind.COps{cotile} <- getsState scops+  let canFlip fact = playerAiLeader (gplayer fact)+                     || isSpawnFact fact+      flipFaction fact | not $ canFlip fact = return ()+      flipFaction fact = do+        case gleader fact of+          Nothing -> return ()+          Just leader -> do+            body <- getsState $ getActorBody leader+            lvl2 <- getLevel $ blid body+            let leaderStuck = waitedLastTurn body+                t = lvl2 `at` bpos body+            -- Keep the leader: he is on stairs and not stuck+            -- and we don't want to clog stairs or get pushed to another level.+            unless (not leaderStuck && Tile.isStair cotile t) $ do+              actorD <- getsState sactorD+              let ourLvl (lid, lvl) =+                    ( lid+                    , EM.size (lfloor lvl)+                    , actorNotProjAssocsLvl (== bfid body) lvl actorD )+              ours <- getsState $ map ourLvl . EM.assocs . sdungeon+              -- Non-humans, being born in the dungeon, have a rough idea of+              -- the number of items left on the level and will focus+              -- on levels they started exploring and that have few items+              -- left. This is to to explore them completely, leave them+              -- once and for all and concentrate forces on another level.+              -- In addition, sole stranded actors tend to become leaders+              -- so that they can join the main force ASAP.+              let freqList = [ (k, (lid, a))+                             | (lid, itemN, (a, b) : rest) <- ours+                             , bhp b > 0  -- drama levels skipped+                             , not leaderStuck || lid /= blid body+                             , let len = 1 + (min 10 $ length rest)+                                   k = 1000000 `div` (3 * itemN + len) ]+              unless (null freqList) $ do+                (lid, a) <- rndToAction $ frequency+                                        $ toFreq "leadLevel" freqList+                unless (lid == blid body) $+                  execCmdAtomic+                  $ LeadFactionA (bfid body) (Just leader) (Just a)+  factionD <- getsState sfactionD+  mapM_ flipFaction $ EM.elems factionD+ -- | Continue or exit or restart the game. endOrLoop :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m () endOrLoop updConn loopServer = do@@ -444,8 +571,8 @@       modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}}       restartGame updConn loopServer     _ | gameOver -> restartGame updConn loopServer-    (_, []) -> loopServer  -- continue current game-    (_, _ : _) -> do+    ([], []) -> loopServer  -- continue current game+    ([], _ : _) -> do       -- Wipe out the quit flag for the savegame files.       mapM_ (\(fid, fact) ->               execCmdAtomic@@ -458,7 +585,7 @@ saveAndExit = do   cops <- getsState scops   -- Save client and server data.-  saveBkpAll+  saveBkpAll True   -- debugPrint "Server saves game before exit"   -- Kill all clients, including those that did not take part   -- in the current game.@@ -476,11 +603,14 @@ restartGame :: (MonadAtomic m, MonadConnServer m)             => m () -> m () -> m () restartGame updConn loopServer = do+  tellGameClipPS   cops <- getsState scops   sdebugNxt <- getsServer sdebugNxt   srandom <- getsServer srandom   s <- gameReset cops sdebugNxt $ Just srandom-  modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt}+  let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}+  modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs+                             , sdebugSer = debugBarRngs }   execCmdAtomic $ RestartServerA s   updConn   initPer
Game/LambdaHack/Server/ServerSem.hs view
@@ -9,6 +9,7 @@ -- TODO: document module Game.LambdaHack.Server.ServerSem where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.Key (mapWithKeyM_)@@ -17,12 +18,13 @@ import Data.Text (Text) import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.AtomicCmd import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item@@ -45,15 +47,18 @@ import Game.LambdaHack.Server.State  execFailure :: (MonadAtomic m, MonadServer m)-            => Actor -> FailureSer -> m ()-execFailure body failureSer = do+            => ActorId -> FailureSer -> m ()+execFailure aid 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).+  body <- getsState $ getActorBody aid   let fid = bfid body       msg = showFailureSer failureSer-  debugPrint $ "execFailure:" <+> showT fid <+> ":" <+> msg-  execSfxAtomic $ MsgFidD fid msg  -- TODO: --more--+  debugPrint+    $ "execFailure:" <+> tshow fid <+> ":" <+> msg <> "\n" <> tshow body+  execSfxAtomic $ MsgFidD fid $ "Unexpected problem:" <+> msg <> "."+    -- TODO: --more--, but keep in history  broadcastCmdAtomic :: MonadAtomic m                    => (FactionId -> CmdAtomic) -> m ()@@ -69,21 +74,16 @@  -- * MoveSer -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--- actors from non-spawning factions leave smell.+-- | Add a smell trace for the actor to the level. For now, only heroes+-- leave smell. addSmell :: MonadAtomic m => ActorId -> m () addSmell aid = do-  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops+  cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops   b <- getsState $ getActorBody aid-  spawn <- getsState $ isSpawnFaction (bfid b)+  fact <- getsState $ (EM.! bfid b) . sfactionD   let canSmell = asmell $ okind $ bkind b-  unless (bproj b || spawn || canSmell) $ do+  unless (bproj b || not (isHeroFact cops fact) || canSmell) $ do     time <- getsState $ getLocalTime $ blid b     lvl <- getLevel $ blid b     let oldS = EM.lookup (bpos b) . lsmell $ lvl@@ -107,17 +107,18 @@   -- We start by checking actors at the the target position.   tgt <- getsState $ posToActor tpos lid   case tgt of-    Just target ->  -- visible or not+    Just ((target, tb), _) | not (bproj sb && bproj tb) ->  -- visible or not       -- Attacking does not require full access, adjacency is enough.+      -- Projectiles are too small to hit each other.       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+          execFailure source MoveNothing  -- * MeleeSer @@ -126,17 +127,20 @@ -- 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.+-- No problem if there are many projectiles at the spot. We just+-- attack the one specified. meleeSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m () meleeSer source target = do-  cops@Kind.COps{coitem=Kind.Ops{opick, okind}} <- getsState scops+  cops@Kind.COps{coitem=coitem@Kind.Ops{opick, okind}} <- getsState scops   sb <- getsState $ getActorBody source   tb <- getsState $ getActorBody target-  adj <- checkAdjacent sb tb-  if not adj then execFailure sb MeleeDistant+  let adj = checkAdjacent sb tb+  if source == target then execFailure source MeleeSelf+  else if not adj then execFailure source MeleeDistant   else do     let sfid = bfid sb         tfid = bfid tb-    time <- getsState $ getLocalTime (blid tb)+    sfact <- getsState $ (EM.! sfid) . sfactionD     itemAssocs <- getsState $ getActorItem source     (miid, item) <-       if bproj sb   -- projectile@@ -146,15 +150,18 @@       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"+          let isHero = isHeroFact cops sfact+              h2hGroup | isHero = "unarmed"+                       | otherwise = "monstrous"           h2hKind <- rndToAction $ fmap (fromMaybe $ assert `failure` h2hGroup)                                    $ opick h2hGroup (const True)           flavour <- getsServer sflavour           discoRev <- getsServer sdiscoRev           let kind = okind h2hKind-              effect = fmap maxDeep (ieffect kind)+          let kindEffect = case causeIEffects coitem h2hKind of+                [] -> NoEffect+                eff : _TODO -> eff+              effect = fmap maxDeep kindEffect           return ( Nothing                  , buildItem flavour discoRev h2hKind kind effect )     let performHit block = do@@ -162,18 +169,17 @@           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.+          -- Msgs inside itemEffect 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+    if braced tb && 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@@ -189,20 +195,26 @@   cops <- getsState scops   sb <- getsState $ getActorBody source   tb <- getsState $ getActorBody target-  adj <- checkAdjacent sb tb-  if not adj then execFailure sb DisplaceDistant+  let adj = checkAdjacent sb tb+  if not adj then execFailure source DisplaceDistant   else do     let lid = blid sb     lvl <- getLevel lid     let spos = bpos sb         tpos = bpos tb+    -- Displacing requires full access.     if accessible cops lvl spos tpos then do-      -- Displacing requires full access.-      execCmdAtomic $ DisplaceActorA source target-      addSmell source+      tgts <- getsState $ posToActors tpos lid+      case tgts of+        [] -> assert `failure` (source, sb, target, tb)+        [_] -> do+          execCmdAtomic $ DisplaceActorA source target+          addSmell source+          addSmell target+        _ -> execFailure source DisplaceProjectiles     else do       -- Client foolishly tries to displace an actor without access.-      execFailure sb DisplaceAccess+      execFailure source DisplaceAccess  -- * AlterSer @@ -217,8 +229,7 @@   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+  if not $ adjacent spos tpos then execFailure source AlterDistant   else do     lvl <- getLevel lid     let serverTile = lvl `at` tpos@@ -243,7 +254,7 @@     as <- getsState $ actorList (const True) lid     if null groupsToAlter && serverTile == freshClientTile then       -- Neither searching nor altering possible; silly client.-      execFailure sb AlterNothing+      execFailure source AlterNothing     else do       if EM.null $ lvl `atI` tpos then         if unoccupied as tpos then do@@ -254,86 +265,111 @@           mapM_ changeTo groupsToAlter           -- Perform an effect, if any permitted.           void $ triggerEffect source feats-        else execFailure sb AlterBlockActor-      else execFailure sb AlterBlockItem+        else execFailure source AlterBlockActor+      else execFailure source 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.+-- | Do nothing.+--+-- Something is sometimes done in 'LoopAction.setBWait'. waitSer :: MonadAtomic m => ActorId -> m ()-waitSer aid = do-  body <- getsState $ getActorBody aid-  time <- getsState $ getLocalTime $ blid body-  let fromWait = bwait body-      toWait = timeAddFromSpeed body time-  execCmdAtomic $ WaitActorA aid fromWait toWait+waitSer _ = return ()  -- * PickupSer -pickupSer :: MonadAtomic m-          => ActorId -> ItemId -> Int -> InvChar -> m ()-pickupSer aid iid k l = assert (k > 0 `blame` "pick up no items"-                                      `twith` (aid, iid, k, l)) $ do+pickupSer ::  (MonadAtomic m, MonadServer m)+          => ActorId -> ItemId -> Int -> m ()+pickupSer aid iid k = assert (k > 0) $ do   b <- getsState $ getActorBody aid-  execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) (CActor aid l)+  item <- getsState $ getItemBody iid+  case actorContainerB aid b iid item of+    Just c -> execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) c+    Nothing -> execFailure aid PickupOverfull  -- * DropSer -dropSer :: MonadAtomic m => ActorId -> ItemId -> m ()-dropSer aid iid = do+dropSer :: MonadAtomic m => ActorId -> ItemId -> Int -> m ()+dropSer aid iid k = assert (k > 0) $ do   b <- getsState $ getActorBody aid-  let k = 1-  execCmdAtomic $ MoveItemA iid k (actorContainer aid (binv b) iid)-                                  (CFloor (blid b) (bpos b))+  let c = actorContainer aid (binv b) iid+  execCmdAtomic $ MoveItemA iid k c (CFloor (blid b) (bpos b))  -- * ProjectSer  projectSer :: (MonadAtomic m, MonadServer m)            => ActorId    -- ^ actor projecting the item (is on current lvl)-           -> Point      -- ^ target position of the projectile+           -> Point    -- ^ target position of the projectile            -> Int        -- ^ digital line parameter            -> ItemId     -- ^ the item to be projected            -> Container  -- ^ whether the items comes from floor or inventory            -> m ()-projectSer source tpos eps iid container = do-  Kind.COps{cotile} <- getsState scops+projectSer source tpxy eps iid container = do+  mfail <- projectFail source tpxy eps iid container False+  maybe skip (execFailure source) mfail++projectFail :: (MonadAtomic m, MonadServer m)+            => ActorId    -- ^ actor projecting the item (is on current lvl)+            -> Point      -- ^ target position of the projectile+            -> Int        -- ^ digital line parameter+            -> ItemId     -- ^ the item to be projected+            -> Container  -- ^ whether the items comes from floor or inventory+            -> Bool       -- ^ whether the item is a shrapnel+            -> m (Maybe FailureSer)+projectFail source tpxy eps iid container isShrapnel = do+  Kind.COps{coactor=Kind.Ops{okind}, 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"-                          `twith` (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+  lvl@Level{lxsize, lysize} <- getLevel lid+  case bla lxsize lysize eps spos tpxy of+    Nothing -> return $ Just ProjectAimOnself+    Just [] -> assert `failure` "projecting from the edge of level"+                      `twith` (spos, tpxy)+    Just (pos : rest) -> do+      let t = lvl `at` pos+      if not $ Tile.isClear cotile t+        then return $ Just ProjectBlockTerrain+        else do+          mab <- getsState $ posToActor pos lid+          if not $ maybe True (bproj . snd . fst) mab+            then+              if isShrapnel then do+                -- Hit the blocking actor.+                projectBla source spos (pos : rest) iid container+                return Nothing+              else return $ Just ProjectBlockActor+            else do+              blockedByFoes <-+                if isShrapnel then return False+                else do+                  fact <- getsState $ (EM.! bfid sb) . sfactionD+                  foes <- getsState $ actorNotProjList (isAtWar fact) lid+                  return $! foesAdjacent lxsize lysize spos foes+              if blockedByFoes then+                return $ Just ProjectBlockFoes+              else if not (asight (okind $ bkind sb) || bproj sb)+                   then return $ Just ProjectBlind+                   else do+                    if isShrapnel && eps `mod` 2 == 0 then+                      -- Make the explosion a bit less regular.+                      projectBla source spos (pos:rest) iid container+                    else+                      projectBla source pos rest iid container+                    return Nothing  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+           -> [Point]    -- ^ rest of the trajectory 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 sb `timeAdd` timeEpsilon-  execSfxAtomic $ ProjectD source iid+      time = btime sb+  unless (bproj sb) $ execSfxAtomic $ ProjectD source iid   projId <- addProjectile pos rest iid lid (bfid sb) time   execCmdAtomic $ MoveItemA iid 1 container (CActor projId (InvChar 'a')) @@ -346,23 +382,25 @@            , coitem=coitem@Kind.Ops{okind=iokind} } <- getsState scops   disco <- getsServer sdisco   item <- getsState $ getItemBody iid-  let ik = iokind (fromJust $ jkind disco item)-      speed = speedFromWeight (iweight ik) (itoThrow ik)+  let lingerPercent = isLingering coitem disco item+      ik = iokind (fromJust $ jkind disco item)+      speed = speedFromWeight (jweight item) (itoThrow ik)       range = rangeFromSpeed speed       adj | range < 5 = "falling"           | otherwise = "flying"       -- 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 (bpos : rest)+      trajectoryLength = lingerPercent * range `div` 100+      dirTrajectory = take trajectoryLength $ pathToTrajectory (bpos : rest)       kind = okind $ projectileKindId coactor       m = actorTemplate (projectileKindId coactor) (asymbol kind) name-                        (acolor kind) speed 0 (Just dirPath)+                        (acolor kind) speed 0 (Just dirTrajectory)                         bpos blid btime bfid True   acounter <- getsServer sacounter   modifyServer $ \ser -> ser {sacounter = succ acounter}   execCmdAtomic $ CreateActorA acounter m [(iid, item)]-  return acounter+  return $! acounter  -- * ApplySer @@ -396,7 +434,7 @@         Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]         Just _ -> []   go <- triggerEffect aid feats-  unless go $ execFailure sb TriggerNothing+  unless go $ execFailure aid TriggerNothing  triggerEffect :: (MonadAtomic m, MonadServer m)               => ActorId -> [F.Feature] -> m Bool@@ -414,39 +452,60 @@   goes <- mapM triggerFeat feats   return $! or goes --- * SetPathSer+-- * SetTrajectorySer -setPathSer :: (MonadAtomic m, MonadServer m)-           => ActorId -> [Vector] -> m ()-setPathSer aid path = do-  when (length path <= 2) $ do-    fromColor <- getsState $ bcolor . getActorBody aid-    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-      execCmdAtomic $ PathActorA aid fromPath (Just lv)+setTrajectorySer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()+setTrajectorySer aid = do+  cops <- getsState scops+  b@Actor{bpos, btrajectory, blid, bcolor} <- getsState $ getActorBody aid+  lvl <- getLevel blid+  let clearTrajectory =+        execCmdAtomic $ TrajectoryActorA aid btrajectory (Just [])+  case btrajectory of+    Just (d : lv) ->+      if not $ accessibleDir cops lvl bpos d+      then clearTrajectory+      else do+        when (length lv <= 1) $ do+          let toColor = Color.BrBlack+          when (bcolor /= toColor) $+            execCmdAtomic $ ColorActorA aid bcolor toColor+        moveSer aid d+        execCmdAtomic $ TrajectoryActorA aid btrajectory (Just lv)+    _ -> assert `failure` "null trajectory" `twith` (aid, b)  -- * GameRestart -gameRestartSer :: (MonadAtomic m, MonadServer m) => ActorId -> Text -> m ()-gameRestartSer aid stInfo = do+-- TODO: implement a handshake and send hero names there,+-- so that they are available in the first game too,+-- not only in subsequent, restarted, games.+gameRestartSer :: (MonadAtomic m, MonadServer m)+               => ActorId -> Text -> Int -> [(Int, Text)] -> m ()+gameRestartSer aid stInfo d configHeroNames = do+  modifyServer $ \ser ->+    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d+                                     , sdebugCli = (sdebugCli (sdebugNxt ser))+                                                     {sdifficultyCli = d}+                                     }}   b <- getsState $ getActorBody aid   let fid = bfid b   oldSt <- getsState $ gquit . (EM.! fid) . sfactionD-  modifyServer $ \ser -> ser {squit = True}  -- do this at once+  modifyServer $ \ser ->+    ser { squit = True  -- do this at once+        , sheroNames = EM.insert fid configHeroNames $ sheroNames ser }   revealItems Nothing Nothing   execCmdAtomic $ QuitFactionA fid (Just b) oldSt                 $ Just $ Status Restart (fromEnum $ blid b) stInfo  -- * GameExit -gameExitSer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-gameExitSer aid = do+gameExitSer :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()+gameExitSer aid d = do+  modifyServer $ \ser ->+    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d+                                     , sdebugCli = (sdebugCli (sdebugNxt ser))+                                                     {sdifficultyCli = d}+                                     }}   b <- getsState $ getActorBody aid   let fid = bfid b   oldSt <- getsState $ gquit . (EM.! fid) . sfactionD
Game/LambdaHack/Server/StartAction.hs view
@@ -1,8 +1,9 @@ -- | Operations for starting and restarting the game. module Game.LambdaHack.Server.StartAction-  ( applyDebug, gameReset, reinitGame, initPer+  ( applyDebug, gameReset, reinitGame, saveBkpAll, initPer   ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St import qualified Data.Char as Char@@ -17,7 +18,6 @@ import Data.Tuple (swap) import qualified System.Random as R -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.AtomicCmd@@ -25,21 +25,21 @@ import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Flavour+import qualified Game.LambdaHack.Common.HighScore as HighScore 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.Point-import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector 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 import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen import Game.LambdaHack.Server.EffectSem import Game.LambdaHack.Server.Fov@@ -58,7 +58,7 @@                                      , sstopAfter                                      , sdbgMsgSer                                      , snewGameSer-                                     , sdumpConfig+                                     , sdumpInitRngs                                      , sdebugCli }}  initPer :: MonadServer m => m ()@@ -68,9 +68,9 @@   pers <- getsState $ dungeonPerception cops (fromMaybe (Digital 12) fovMode)   modifyServer $ \ser1 -> ser1 {sper = pers} -reinitGame :: (MonadAtomic m, MonadServer m) => m ()+reinitGame :: (MonadAtomic m, MonadConnServer m) => m () reinitGame = do-  Kind.COps{ coitem=Kind.Ops{okind}, corule } <- getsState scops+  Kind.COps{coitem=Kind.Ops{okind}, corule} <- getsState scops   pers <- getsServer sper   knowMap <- getsServer $ sknowMap . sdebugSer   -- This state is quite small, fit for transmition to the client.@@ -89,7 +89,26 @@   broadcastCmdAtomic     $ \fid -> RestartA fid sdisco (pers EM.! fid) defLoc sdebugCli modeName   populateDungeon+  saveBkpAll False +-- TODO: 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) => Bool -> m ()+saveBkpAll unconditional = do+  factionD <- getsState sfactionD+  let ping fid _ = do+        sendPingAI fid+        when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid+  mapWithKeyM_ ping factionD+  bench <- getsServer $ sbenchmark . sdebugSer+  when (unconditional || not bench) $ do+    execCmdAtomic SaveBkpA+    saveServer+ mapFromInvFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a mapFromInvFuns =   let fromFun f m1 =@@ -117,7 +136,7 @@         let gdipl = EM.empty  -- fixed below             gquit = Nothing             gleader = Nothing-        return Faction{..}+        return $! Faction{..}   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@@ -142,18 +161,21 @@       -- War overrides alliance, so 'warFs' second.       allianceFs = mkDipl Alliance rawFs (swapIx (playersAlly players))       warFs = mkDipl War allianceFs (swapIx (playersEnemy players))-  return warFs+  return $! warFs  gameReset :: MonadServer m           => Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State-gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}, corule}+gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}}           sdebug mrandom = 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 mrandom-  scoreTable <- restoreScore sconfig+  dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom+  srandom <- getSetGen $ smainRng sdebug `mplus` mrandom+  scoreTable <- if sbenchmark sdebug then+                  return HighScore.empty+                else+                  restoreScore cops   sstart <- getsServer sstart  -- copy over from previous game+  sallTime <- getsServer sallTime  -- copy over from previous game+  sheroNames <- getsServer sheroNames  -- copy over from previous game   let smode = sgameMode sdebug       rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev,                   DungeonGen.FreshDungeon)@@ -169,10 +191,13 @@   let (faction, sflavour, sdisco, sdiscoRev, DungeonGen.FreshDungeon{..}) =         St.evalState rnd dungeonSeed       defState = defStateGlobal freshDungeon freshDepth faction cops scoreTable-      defSer = emptyStateServer-                 {sdisco, sdiscoRev, sflavour, srandom, sconfig, sstart}+      defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom+                                , srngs = RNGs (Just dungeonSeed)+                                               (Just srandom) }   putServer defSer-  return defState+  when (sbenchmark sdebug) resetGameStart+  modifyServer $ \ser -> ser {sdisco, sdiscoRev, sflavour}+  return $! defState  -- Spawn initial actors. Clients should notice this, to set their leaders. populateDungeon :: (MonadAtomic m, MonadServer m) => m ()@@ -192,7 +217,7 @@   dungeon <- getsState sdungeon   mapWithKeyM_ initialItems dungeon   factionD <- getsState sfactionD-  Config{configHeroNames} <- getsServer sconfig+  sheroNames <- getsServer sheroNames   let (minD, maxD) =         case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)@@ -218,10 +243,11 @@         psFree <- getsState $ nearbyFreePoints cotile validTile ppos lid         let ps = take (playerInitial $ gplayer fact) $ zip [0..] psFree         forM_ ps $ \ (n, p) ->-          if isSpawnFact cops fact+          if not $ isHeroFact cops fact           then spawnMonsters [p] lid ntime side           else do-            aid <- addHero side p lid configHeroNames (Just n) ntime+            let hNames = fromMaybe [] $ EM.lookup side sheroNames+            aid <- addHero side p lid hNames (Just n) ntime             mleader <- getsState                        $ gleader . (EM.! side) . sfactionD  -- just changed             when (isNothing mleader) $@@ -233,7 +259,7 @@ findEntryPoss :: Kind.COps -> Level -> Int -> Rnd [Point] findEntryPoss Kind.COps{cotile} Level{ltile, lxsize, lysize, lstair} k = do   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 l pos > cmin) poss       tryFind _ 0 = return []       tryFind ps n = do         np <- findPosTry 1000 ltile  -- try really hard, for skirmish fairness@@ -245,9 +271,9 @@                 , dist ps $ factionDist `div` 16                 ]         nps <- tryFind (np : ps) (n - 1)-        return $ np : nps+        return $! np : nps       stairPoss = fst lstair ++ snd lstair-      middlePos = toPoint lxsize $ PointXY (lxsize `div` 2, lysize `div` 2)+      middlePos = Point (lxsize `div` 2) (lysize `div` 2)   assert (k > 0 && factionDist > 0) skip   case k of     1 -> tryFind stairPoss k
Game/LambdaHack/Server/State.hs view
@@ -2,11 +2,13 @@ module Game.LambdaHack.Server.State   ( StateServer(..), emptyStateServer   , DebugModeSer(..), defDebugModeSer+  , RNGs(..)   ) where  import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.HashMap.Strict as HM+import Data.List import Data.Text (Text) import qualified System.Random as R import System.Time@@ -14,28 +16,33 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.AtomicCmd+import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Server.Config-import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.RuleKind  -- | Global, server state. data StateServer = StateServer-  { sdisco    :: !Discovery     -- ^ full item discoveries data-  , sdiscoRev :: !DiscoRev      -- ^ reverse disco map, used for item creation-  , sitemRev  :: !ItemRev       -- ^ reverse id map, used for item creation-  , sflavour  :: !FlavourMap    -- ^ association of flavour to items-  , sacounter :: !ActorId       -- ^ stores next actor index-  , sicounter :: !ItemId        -- ^ stores next item index-  , sundo     :: ![Atomic]      -- ^ atomic commands performed to date-  , sper      :: !Pers          -- ^ perception of all factions-  , srandom   :: !R.StdGen      -- ^ current random generator-  , 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+  { sdisco     :: !Discovery     -- ^ full item discoveries data+  , sdiscoRev  :: !DiscoRev      -- ^ reverse disco map, used for item creation+  , sitemRev   :: !ItemRev       -- ^ reverse id map, used for item creation+  , sflavour   :: !FlavourMap    -- ^ association of flavour to items+  , sacounter  :: !ActorId       -- ^ stores next actor index+  , sicounter  :: !ItemId        -- ^ stores next item index+  , sundo      :: ![Atomic]      -- ^ atomic commands performed to date+  , sper       :: !Pers          -- ^ perception of all factions+  , srandom    :: !R.StdGen      -- ^ current random generator+  , srngs      :: !RNGs          -- ^ initial random generators+  , squit      :: !Bool          -- ^ exit the game loop+  , sbkpSave   :: !Bool          -- ^ make backup savefile now+  , sstart     :: !ClockTime     -- ^ this session start time+  , sgstart    :: !ClockTime     -- ^ this game start time+  , sallTime   :: !Time          -- ^ clips since the start of the session+  , sheroNames :: !(EM.EnumMap FactionId [(Int, Text)])+                                 -- ^ hero names sent by clients+  , sdebugSer  :: !DebugModeSer  -- ^ current debugging mode+  , sdebugNxt  :: !DebugModeSer  -- ^ debugging mode for the next game   }   deriving (Show) @@ -48,15 +55,32 @@   , sallClear      :: !Bool   , sgameMode      :: !Text   , sstopAfter     :: !(Maybe Int)+  , sbenchmark     :: !Bool+  , sdungeonRng    :: !(Maybe R.StdGen)+  , smainRng       :: !(Maybe R.StdGen)   , sfovMode       :: !(Maybe FovMode)   , snewGameSer    :: !Bool-  , sdumpConfig    :: !Bool+  , sdifficultySer :: !Int+  , sdumpInitRngs  :: !Bool   , ssavePrefixSer :: !(Maybe String)   , sdbgMsgSer     :: !Bool   , sdebugCli      :: !DebugModeCli   }   deriving Show +data RNGs = RNGs+  { dungeonRandomGenerator  :: !(Maybe R.StdGen)+  , startingRandomGenerator :: !(Maybe R.StdGen)+  }++instance Show RNGs where+  show RNGs{..} =+    let args = [ maybe "" (\gen -> "--setDungeonRng \"" ++ show gen ++ "\"")+                       dungeonRandomGenerator+               , maybe "" (\gen -> "--setMainRng \"" ++ show gen ++ "\"")+                       startingRandomGenerator ]+    in intercalate " " args+ -- | Initial, empty game server state. emptyStateServer :: StateServer emptyStateServer =@@ -70,10 +94,14 @@     , sundo = []     , sper = EM.empty     , srandom = R.mkStdGen 42-    , sconfig = undefined+    , srngs = RNGs { dungeonRandomGenerator = Nothing+                   , startingRandomGenerator = Nothing }     , squit = False     , sbkpSave = False     , sstart = TOD 0 0+    , sgstart = TOD 0 0+    , sallTime = timeZero+    , sheroNames = EM.empty     , sdebugSer = defDebugModeSer     , sdebugNxt = defDebugModeSer     }@@ -86,9 +114,13 @@                                , sallClear = False                                , sgameMode = "campaign"                                , sstopAfter = Nothing+                               , sbenchmark = False+                               , sdungeonRng = Nothing+                               , smainRng = Nothing                                , sfovMode = Nothing                                , snewGameSer = False-                               , sdumpConfig = False+                               , sdifficultySer = 0+                               , sdumpInitRngs = False                                , ssavePrefixSer = Nothing                                , sdbgMsgSer = False                                , sdebugCli = defDebugModeCli@@ -104,7 +136,8 @@     put sicounter     put sundo     put (show srandom)-    put sconfig+    put srngs+    put sheroNames     put sdebugSer   get = do     sdisco <- get@@ -115,15 +148,18 @@     sicounter <- get     sundo <- get     g <- get-    sconfig <- get+    srngs <- get+    sheroNames <- get     sdebugSer <- get     let srandom = read g         sper = EM.empty         squit = False         sbkpSave = False         sstart = TOD 0 0-        sdebugNxt = defDebugModeSer-    return StateServer{..}+        sgstart = TOD 0 0+        sallTime = timeZero+        sdebugNxt = defDebugModeSer  -- TODO: here difficulty level, etc. from the last session is wiped out+    return $! StateServer{..}  instance Binary DebugModeSer where   put DebugModeSer{..} = do@@ -133,6 +169,7 @@     put sniffOut     put sallClear     put sgameMode+    put sdifficultySer     put sfovMode     put ssavePrefixSer     put sdbgMsgSer@@ -144,11 +181,26 @@     sniffOut <- get     sallClear <- get     sgameMode <- get+    sdifficultySer <- get     sfovMode <- get     ssavePrefixSer <- get     sdbgMsgSer <- get     sdebugCli <- get     let sstopAfter = Nothing+        sbenchmark = False+        sdungeonRng = Nothing+        smainRng = Nothing         snewGameSer = False-        sdumpConfig = False-    return DebugModeSer{..}+        sdumpInitRngs = False+    return $! DebugModeSer{..}++instance Binary RNGs where+  put RNGs{..} = do+    put (show dungeonRandomGenerator)+    put (show startingRandomGenerator)+  get = do+    dg <- get+    sg <- get+    let dungeonRandomGenerator = read dg+        startingRandomGenerator = read sg+    return $! RNGs{..}
Game/LambdaHack/Utils/File.hs view
@@ -1,20 +1,32 @@ -- | Saving/loading with serialization and compression. module Game.LambdaHack.Utils.File-  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles+  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir   ) where  import qualified Codec.Compression.Zlib as Z+import qualified Control.Exception as Ex import Control.Monad import Data.Binary import qualified Data.ByteString.Lazy as LBS+import qualified Data.Char as Char import System.Directory+import System.Environment import System.FilePath import System.IO  -- | Serialize, compress and save data. -- Note that LBS.writeFile opens the file in binary mode. encodeData :: Binary a => FilePath -> a -> IO ()-encodeData f = LBS.writeFile f . Z.compress . encode+encodeData f a = do+  let tmpPath = f <.> "tmp"+  Ex.bracketOnError+    (openBinaryFile tmpPath WriteMode)+    (\h -> hClose h >> removeFile tmpPath)+    (\h -> do+       LBS.hPut h . Z.compress . encode $ a+       hClose h+       renameFile tmpPath f+    )  -- | Serialize, compress and save data with an EOF marker. -- The @OK@ is used as an EOF marker to ensure any apparent problems with@@ -41,7 +53,7 @@ strictDecodeEOF f = do   (a, n) <- strictDecodeData f   if n == ("OK" :: String)-    then return a+    then return $! a     else error $ "Fatal error: corrupted file " ++ f  -- | Try to create a directory, if it doesn't exist. Terminate the program@@ -56,11 +68,19 @@                  -> (FilePath -> IO FilePath)                  -> [(FilePath, FilePath)]                  -> IO ()-tryCopyDataFiles configAppDataDir pathsDataFile files =+tryCopyDataFiles dataDir pathsDataFile files =   let cpFile (fin, fout) = do-        pathsDataIn <- pathsDataFile $ takeFileName fin+        pathsDataIn <- pathsDataFile fin         bIn <- doesFileExist pathsDataIn-        let pathsDataOut = configAppDataDir </> fout+        let pathsDataOut = dataDir </> fout         bOut <- doesFileExist pathsDataOut         when (not bOut && bIn) $ copyFile pathsDataIn pathsDataOut   in mapM_ cpFile files++-- | Personal data directory for the game. Depends on the OS and the game,+-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.+appDataDir :: IO FilePath+appDataDir = do+  progName <- getProgName+  let name = takeWhile Char.isAlphaNum progName+  getAppUserDataDirectory name
Game/LambdaHack/Utils/Frequency.hs view
@@ -13,6 +13,7 @@  import Control.Applicative import Control.Arrow (first, second)+import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import Data.Foldable (Foldable)@@ -20,7 +21,6 @@ import Data.Traversable (Traversable) import qualified System.Random as R -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Msg  -- TODO: do not expose runFrequency@@ -32,6 +32,7 @@   deriving (Show, Eq, Foldable, Traversable)  instance Monad Frequency where+  {-# INLINE return #-}   return x = Frequency "return" [(1, x)]   Frequency name xs >>= f =     Frequency ("bind (" <> name <> ")")@@ -42,8 +43,8 @@   fmap f (Frequency name xs) = Frequency name (map (second f) xs)  instance Applicative Frequency where-    pure  = return-    (<*>) = ap+  pure  = return+  (<*>) = ap  instance MonadPlus Frequency where   mplus (Frequency xname xs) (Frequency yname ys) =@@ -56,8 +57,8 @@   mzero = Frequency "[]" []  instance Alternative Frequency where-    (<|>) = mplus-    empty = mzero+  (<|>) = mplus+  empty = mzero  -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a@@ -116,4 +117,4 @@   get = do     nameFrequency <- get     runFrequency <- get-    return Frequency{..}+    return $! Frequency{..}
+ GameDefinition/Content/ActorKind.hs view
@@ -0,0 +1,88 @@+-- | Monsters and heroes for LambdaHack.+module Content.ActorKind ( cdefs ) where++import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ActorKind++cdefs :: ContentDef ActorKind+cdefs = ContentDef+  { getSymbol = asymbol+  , getName = aname+  , getFreq = afreq+  , validate = validateActorKind+  , content =+      [hero, projectile, eye, fastEye, nose]+  }+hero,        projectile, eye, fastEye, nose :: ActorKind++hero = ActorKind+  { asymbol = '@'+  , aname   = "hero"+  , afreq   = [("hero", 1)]+  , acolor  = BrWhite  -- modified if many hero factions+  , ahp     = rollDice 50 1+  , aspeed  = toSpeed 2+  , asight  = True+  , asmell  = False+  , aiq     = 15  -- higher that that leads to looping movement+  , aregen  = 500+  , acanDo  = [minBound..maxBound]+  }++projectile = ActorKind  -- includes homing missiles+  { asymbol = '*'+  , aname   = "projectile"+  , afreq   = [("projectile", 1)]  -- Does not appear randomly in the dungeon.+  , acolor  = BrWhite+  , ahp     = rollDice 0 0+  , aspeed  = toSpeed 0+  , asight  = False+  , asmell  = False+  , aiq     = 0+  , aregen  = maxBound+  , acanDo  = [Track]+  }++eye = ActorKind+  { asymbol = 'e'+  , aname   = "reducible eye"+  , afreq   = [("monster", 60), ("horror", 60)]+  , acolor  = BrRed+  , ahp     = rollDice 7 4+  , aspeed  = toSpeed 2+  , asight  = True+  , asmell  = False+  , aiq     = 8+  , aregen  = 100+  , acanDo  = [minBound..maxBound]+  }+fastEye = ActorKind+  { asymbol = 'e'+  , aname   = "super-fast eye"+  , afreq   = [("monster", 15), ("horror", 15)]+  , acolor  = BrBlue+  , ahp     = rollDice 1 6+  , aspeed  = toSpeed 4+  , asight  = True+  , asmell  = False+  , aiq     = 12+  , aregen  = 10  -- Regenerates fast (at max HP most of the time!).+  , acanDo  = [minBound..maxBound]+  }+nose = ActorKind+  { asymbol = 'n'+  , aname   = "point-free nose"+  , afreq   = [("monster", 20), ("horror", 20)]+  , acolor  = Green+  , ahp     = rollDice 17 2+  , aspeed  = toSpeed 1.8+  , asight  = False+  , asmell  = True+  , aiq     = 0+  , aregen  = 100+  , acanDo  = [minBound..maxBound]+  }
+ GameDefinition/Content/CaveKind.hs view
@@ -0,0 +1,123 @@+-- | Cave layouts for LambdaHack.+module Content.CaveKind ( cdefs ) where++import Data.Ratio++import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Random as Random+import Game.LambdaHack.Content.CaveKind++cdefs :: ContentDef CaveKind+cdefs = ContentDef+  { getSymbol = csymbol+  , getName = cname+  , getFreq = cfreq+  , validate = validateCaveKind+  , content =+      [rogue, arena, empty, noise, combat, battle]+  }+rogue,        arena, empty, noise, combat, battle :: CaveKind++rogue = CaveKind+  { csymbol       = '$'+  , cname         = "A maze of twisty passages"+  , cfreq         = [("dng", 100), ("caveRogue", 1)]+  , cxsize        = fst normalLevelBound + 1+  , cysize        = snd normalLevelBound + 1+  , cgrid         = rollDiceXY [(3, 2)] [(1, 2), (2, 1)]+  , cminPlaceSize = rollDiceXY [(2, 2), (2, 1)] [(4, 1)]+  , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound, 1)]+                               [(snd normalLevelBound, 1)]+  , cdarkChance   = rollDeep (1, 54) (0, 0)+  , cnightChance  = intToDeep 100+  , cauxConnects  = 1%3+  , cmaxVoid      = 1%6+  , cminStairDist = 30+  , cdoorChance   = 1%2+  , copenChance   = 1%10+  , chidden       = 8+  , citemNum      = rollDice 7 2+  , citemFreq     = [(70, "useful"), (30, "treasure")]+  , cdefTile        = "fillerWall"+  , cdarkCorTile    = "floorCorridorDark"+  , clitCorTile     = "floorCorridorLit"+  , cfillerTile     = "fillerWall"+  , couterFenceTile = "basic outer fence"+  , clegendDarkTile = "legendDark"+  , clegendLitTile  = "legendLit"+  }+arena = rogue+  { csymbol       = 'A'+  , cname         = "Underground city"+  , cfreq         = [("dng", 30), ("caveArena", 1)]+  , cgrid         = rollDiceXY [(2, 2)] [(2, 2)]+  , cminPlaceSize = rollDiceXY [(2, 2), (3, 1)] [(4, 1)]+  , cdarkChance   = rollDeep (1, 80) (1, 60)+  , cnightChance  = intToDeep 0+  , cmaxVoid      = 1%3+  , chidden       = 1000+  , citemNum      = rollDice 5 2  -- few rooms+  , cdefTile      = "arenaSet"+  , cdarkCorTile  = "trailLit"  -- let paths around rooms be lit+  , clitCorTile   = "trailLit"+  }+empty = rogue+  { csymbol       = '.'+  , cname         = "Tall cavern"+  , cfreq         = [("dng", 20), ("caveEmpty", 1)]+  , cgrid         = rollDiceXY [(1, 2), (1, 1)] [(1, 1)]+  , cminPlaceSize = rollDiceXY [(10, 1)] [(10, 1)]+  , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound * 3 `div` 5, 1)]+                               [(snd normalLevelBound * 3 `div` 5, 1)]+  , cdarkChance   = rollDeep (1, 80) (1, 80)+  , cnightChance  = intToDeep 0+  , cauxConnects  = 1+  , cmaxVoid      = 1%2+  , cminStairDist = 50+  , chidden       = 1000+  , citemNum      = rollDice 8 2  -- whole floor strewn with treasure+  , cdefTile      = "emptySet"+  , cdarkCorTile  = "trailLit"  -- let paths around rooms be lit+  , clitCorTile   = "floorArenaLit"+  }+noise = rogue+  { csymbol       = '!'+  , cname         = "Glittering cave"+  , cfreq         = [("dng", 20), ("caveNoise", 1)]+  , cgrid         = rollDiceXY [(2, 2)] [(1, 2), (1, 1)]+  , cminPlaceSize = rollDiceXY [(3, 2), (2, 1)] [(5, 1)]+  , cdarkChance   = rollDeep (1, 80) (1, 40)+  , cnightChance  = rollDeep (1, 40) (1, 40)+  , cmaxVoid      = 0+  , chidden       = 1000+  , citemNum      = rollDice 4 2  -- fewer rooms+  , cdefTile      = "noiseSet"+  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , clitCorTile   = "trailLit"+  }+combat = rogue+  { csymbol       = 'C'+  , cname         = "Combat arena"+  , cfreq         = [("caveCombat", 1)]+  , cgrid         = rollDiceXY [(2, 2), (3, 1)] [(1, 2), (2, 1)]+  , cminPlaceSize = rollDiceXY [(3, 1)] [(3, 1)]+  , cmaxPlaceSize = rollDiceXY [(5, 1)] [(5, 1)]+  , cdarkChance   = intToDeep 100+  , cnightChance  = rollDeep (1, 67) (0, 0)+  , chidden       = 1000+  , cauxConnects  = 0+  , cdoorChance   = 1+  , copenChance   = 0+  , citemNum      = rollDice 12 2+  , citemFreq     = [(100, "useful")]+  , cdefTile      = "combatSet"+  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , clitCorTile   = "floorArenaLit"+  }+battle = combat  -- TODO: actors can get stuck forever among trees+  { csymbol       = 'B'+  , cname         = "Battle arena"+  , cfreq         = [("caveBattle", 1)]+  , cdefTile      = "battleSet"+  }
+ GameDefinition/Content/FactionKind.hs view
@@ -0,0 +1,55 @@+-- | 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++cdefs :: ContentDef FactionKind+cdefs = ContentDef+  { getSymbol = fsymbol+  , getName = fname+  , getFreq = ffreq+  , validate = validateFactionKind+  , content =+      [hero, monster, horror]+  }+hero,        monster, horror :: FactionKind++hero = FactionKind+  { fsymbol        = '@'+  , fname          = "hero"+  , ffreq          = [("hero", 1)]+  , fAbilityLeader = allAbilities+  , fAbilityOther  = meleeAdjacent+  }++monster = FactionKind+  { fsymbol        = 'm'+  , fname          = "monster"+  , ffreq          = [("monster", 1), ("summon", 50)]+  , fAbilityLeader = allAbilities+  , fAbilityOther  = allAbilities+  }++horror = FactionKind+  { 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]
+ GameDefinition/Content/ItemKind.hs view
@@ -0,0 +1,267 @@+-- | Weapons and treasure for LambdaHack.+module Content.ItemKind ( cdefs ) where++import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.ItemFeature+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Content.ItemKind++cdefs :: ContentDef ItemKind+cdefs = ContentDef+  { getSymbol = isymbol+  , getName = iname+  , getFreq = ifreq+  , validate = validateItemKind+  , content =+      [amulet, dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle, fragrance, mist_healing, mist_wounding, glass_piece, smoke]+  }+amulet,        dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle, fragrance, mist_healing, mist_wounding, glass_piece, smoke :: ItemKind++gem, potion, scroll, wand :: ItemKind  -- generic templates++-- castDeep (aDb, xDy) = castDice aDb + (lvl - 1) * castDice xDy / (depth - 1)++amulet = ItemKind+  { isymbol  = '"'+  , iname    = "amulet"+  , ifreq    = [("useful", 6)]+  , iflavour = zipFancy [BrGreen]+  , icount   = intToDeep 1+  , iverbApply   = "tear down"+  , iverbProject = "cast"+  , iweight  = 30+  , itoThrow = -50  -- not dense enough+  , ifeature = [Cause $ Regeneration (rollDeep (2, 3) (1, 10))]+  }+dart = ItemKind+  { isymbol  = '|'+  , iname    = "dart"+  , ifreq    = [("useful", 20)]+  , iflavour = zipPlain [Cyan]+  , icount   = rollDeep (3, 3) (0, 0)+  , iverbApply   = "snap"+  , iverbProject = "hurl"+  , iweight  = 50+  , itoThrow = 0  -- a cheap dart+  , ifeature = [Cause $ Hurt (rollDice 1 2) (rollDeep (1, 2) (1, 2))]+  }+gem = ItemKind+  { isymbol  = '*'+  , iname    = "gem"+  , ifreq    = [("treasure", 20)]  -- x3, but rare on shallow levels+  , iflavour = zipPlain brightCol  -- natural, so not fancy+  , icount   = intToDeep 0+  , iverbApply   = "crush"+  , iverbProject = "toss"+  , iweight  = 50+  , itoThrow = 0+  , ifeature = []+  }+gem1 = gem+  { icount   = rollDeep (0, 0) (1, 1)  -- appears on max depth+  }+gem2 = gem+  { icount   = rollDeep (0, 0) (1, 2)  -- appears halfway+  }+gem3 = gem+  { icount   = rollDeep (0, 0) (1, 3)  -- appears early+  }+currency = ItemKind+  { isymbol  = '$'+  , iname    = "gold piece"+  , ifreq    = [("treasure", 20), ("currency", 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = rollDeep (0, 0) (10, 10)  -- appears on lvl 2+  , iverbApply   = "grind"+  , iverbProject = "toss"+  , iweight  = 31+  , itoThrow = 0+  , ifeature = []+  }+harpoon = ItemKind+  { isymbol  = '|'+  , iname    = "harpoon"+  , ifreq    = [("useful", 25)]+  , iflavour = zipPlain [Brown]+  , icount   = rollDeep (0, 0) (2, 2)+  , iverbApply   = "break up"+  , iverbProject = "hurl"+  , iweight  = 4000+  , itoThrow = 0  -- cheap but deadly+  , ifeature = [Cause $ Hurt (rollDice 2 2) (rollDeep (1, 2) (2, 2))]+  }+potion = ItemKind+  { isymbol  = '!'+  , iname    = "potion"+  , ifreq    = [("useful", 15)]+  , iflavour = zipFancy stdCol+  , icount   = intToDeep 1+  , iverbApply   = "gulp down"+  , iverbProject = "lob"+  , iweight  = 200+  , itoThrow = -50  -- oily, bad grip+  , ifeature = []+  }+potion1 = potion+  { ifreq    = [("useful", 5)]+  , ifeature = [Cause ApplyPerfume, Explode "fragrance"]+  }+potion2 = potion+  { ifeature = [Cause $ Heal 5, Explode "mist healing"]+  }+potion3 = potion+  { ifreq    = [("useful", 5)]+  , ifeature = [Cause $ Heal (-5), Explode "mist wounding"]+  }+ring = ItemKind+  { isymbol  = '='+  , iname    = "ring"+  , ifreq    = []  -- [("useful", 10)]  -- TODO: make it useful+  , iflavour = zipPlain [White]+  , icount   = intToDeep 1+  , iverbApply   = "squeeze down"+  , iverbProject = "toss"+  , iweight  = 15+  , itoThrow = 0+  , ifeature = [Cause $ Searching (rollDeep (1, 6) (3, 2))]+  }+scroll = ItemKind+  { isymbol  = '?'+  , iname    = "scroll"+  , ifreq    = [("useful", 4)]+  , iflavour = zipFancy darkCol  -- arcane and old+  , icount   = intToDeep 1+  , iverbApply   = "decipher"+  , iverbProject = "lob"+  , iweight  = 50+  , itoThrow = -75  -- bad shape, even rolled up+  , ifeature = []+  }+scroll1 = scroll+  { ifreq    = [("useful", 2)]+  , ifeature = [Cause $ CallFriend 1]+  }+scroll2 = scroll+  { ifeature = [Cause $ Summon 1]+  }+scroll3 = scroll+  { ifeature = [Cause $ Ascend (-1)]+  }+sword = ItemKind+  { isymbol  = ')'+  , iname    = "sword"+  , ifreq    = [("useful", 40)]+  , iflavour = zipPlain [BrCyan]+  , icount   = intToDeep 1+  , iverbApply   = "hit"+  , iverbProject = "heave"+  , iweight  = 2000+  , itoThrow = -50  -- ensuring it hits with the tip costs speed+  , ifeature = [Cause $ Hurt (rollDice 5 1) (rollDeep (1, 2) (4, 2))]+  }+wand = ItemKind+  { isymbol  = '/'+  , iname    = "wand"+  , ifreq    = [("useful", 5)]+  , iflavour = zipFancy brightCol+  , icount   = intToDeep 1+  , iverbApply   = "snap"+  , iverbProject = "zap"+  , iweight  = 300+  , itoThrow = 25  -- magic+  , ifeature = [Fragile]+  }+wand1 = wand+  { ifeature = ifeature wand ++ [Cause Dominate]+  }+wand2 = wand+  { ifreq    = [("useful", 2)]+  , ifeature = ifeature wand ++ [Cause $ Heal (-25)]+  }+fist = sword+  { isymbol  = '@'+  , iname    = "fist"+  , ifreq    = [("hth", 1), ("unarmed", 100)]+  , iverbApply   = "punch"+  , iverbProject = "ERROR, please report: iverbProject fist"+  , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)]+  }+foot = sword+  { isymbol  = '@'+  , iname    = "foot"+  , ifreq    = [("hth", 1), ("unarmed", 50)]+  , iverbApply   = "kick"+  , iverbProject = "ERROR, please report: iverbProject foot"+  , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)]+  }+tentacle = sword+  { isymbol  = 'S'+  , iname    = "tentacle"+  , ifreq    = [("hth", 1), ("monstrous", 100)]+  , iverbApply   = "hit"+  , iverbProject = "ERROR, please report: iverbProject tentacle"+  , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)]+  }+fragrance = ItemKind+  { isymbol  = '\''+  , iname    = "fragrance"+  , ifreq    = [("fragrance", 1)]+  , iflavour = zipFancy [BrMagenta]+  , icount   = rollDeep (5, 2) (0, 0)+  , iverbApply   = "smell"+  , iverbProject = "exude"+  , iweight  = 1+  , itoThrow = -93  -- the slowest that gets anywhere (1 step only)+  , ifeature = [Fragile]+  }+mist_healing = ItemKind+  { isymbol  = '\''+  , iname    = "mist"+  , ifreq    = [("mist healing", 1)]+  , iflavour = zipFancy [White]+  , icount   = rollDeep (12, 2) (0, 0)+  , iverbApply   = "inhale"+  , iverbProject = "blow"+  , iweight  = 1+  , itoThrow = -87  -- the slowest that travels at least 2 steps+  , ifeature = [Cause $ Heal 1, Fragile]+  }+mist_wounding = ItemKind+  { isymbol  = '\''+  , iname    = "mist"+  , ifreq    = [("mist wounding", 1)]+  , iflavour = zipFancy [White]+  , icount   = rollDeep (12, 2) (0, 0)+  , iverbApply   = "inhale"+  , iverbProject = "blow"+  , iweight  = 1+  , itoThrow = -87+  , ifeature = [Cause $ Heal (-1), Fragile]+  }+glass_piece = ItemKind+  { isymbol  = '\''+  , iname    = "glass piece"+  , ifreq    = [("glass piece", 1)]+  , iflavour = zipPlain [BrBlue]+  , icount   = rollDeep (10, 2) (0, 0)+  , iverbApply   = "grate"+  , iverbProject = "toss"+  , iweight  = 10+  , itoThrow = 0+  , ifeature = [Cause $ Hurt (rollDice 1 1) (intToDeep 0), Fragile, Linger 20]+  }+smoke = ItemKind+  { isymbol  = '\''+  , iname    = "smoke"+  , ifreq    = [("smoke", 1)]+  , iflavour = zipPlain [BrBlack]+  , icount   = rollDeep (12, 2) (0, 0)+  , iverbApply   = "inhale"+  , iverbProject = "blow"+  , iweight  = 1+  , itoThrow = -70+  , ifeature = [Fragile]+  }
+ GameDefinition/Content/ModeKind.hs view
@@ -0,0 +1,301 @@+-- | 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 = validateModeKind+  , content =+      [campaign, skirmish, battle, pvp, coop, defense, testCampaign, testSkirmish, testBattle, testPvP, testCoop, testDefense, peekCampaign, peekSkirmish]+  }+campaign,        skirmish, battle, pvp, coop, defense, testCampaign, testSkirmish, testBattle, testPvP, testCoop, testDefense, peekCampaign, peekSkirmish :: ModeKind++campaign = ModeKind+  { msymbol  = 'r'+  , mname    = "campaign"+  , mfreq    = [("campaign", 1)]+  , mplayers = playersCampaign+  , mcaves   = cavesCampaign+  }++skirmish = ModeKind+  { msymbol  = 'k'+  , mname    = "skirmish"+  , mfreq    = [("skirmish", 1)]+  , mplayers = playersSkirmish+  , mcaves   = cavesCombat+  }++battle = ModeKind+  { msymbol  = 'b'+  , mname    = "battle"+  , mfreq    = [("battle", 1)]+  , mplayers = playersBattle+  , mcaves   = cavesBattle+  }++pvp = ModeKind+  { msymbol  = 'v'+  , mname    = "PvP"+  , mfreq    = [("PvP", 1)]+  , mplayers = playersPvP+  , mcaves   = cavesCombat+  }++coop = ModeKind+  { msymbol  = 'o'+  , mname    = "Coop"+  , mfreq    = [("Coop", 1)]+  , mplayers = playersCoop+  , mcaves   = cavesCampaign+  }++defense = ModeKind+  { msymbol  = 'e'+  , mname    = "defense"+  , mfreq    = [("defense", 1)]+  , mplayers = playersDefense+  , mcaves   = cavesCampaign+  }++testCampaign = ModeKind+  { msymbol  = 't'+  , mname    = "testCampaign"+  , mfreq    = [("testCampaign", 1)]+  , mplayers = playersTestCampaign+  , mcaves   = cavesCampaign+  }++testSkirmish = ModeKind+  { msymbol  = 't'+  , mname    = "testSkirmish"+  , mfreq    = [("testSkirmish", 1)]+  , mplayers = playersTestSkirmish+  , mcaves   = cavesCombat+  }++testBattle = ModeKind+  { msymbol  = 't'+  , mname    = "testBattle"+  , mfreq    = [("testBattle", 1)]+  , mplayers = playersTestBattle+  , mcaves   = cavesBattle+  }++testPvP = ModeKind+  { msymbol  = 't'+  , mname    = "testPvP"+  , mfreq    = [("testPvP", 1)]+  , mplayers = playersTestPvP+  , mcaves   = cavesCombat+  }++testCoop = ModeKind+  { msymbol  = 't'+  , mname    = "testCoop"+  , mfreq    = [("testCoop", 1)]+  , mplayers = playersTestCoop+  , mcaves   = cavesCampaign+  }++testDefense = ModeKind+  { msymbol  = 't'+  , mname    = "testDefense"+  , mfreq    = [("testDefense", 1)]+  , mplayers = playersTestDefense+  , mcaves   = cavesCampaign+  }++peekCampaign = ModeKind+  { msymbol  = 'p'+  , mname    = "peekCampaign"+  , mfreq    = [("peekCampaign", 1)]+  , mplayers = playersPeekCampaign+  , mcaves   = cavesCampaign+  }++peekSkirmish = ModeKind+  { msymbol  = 'p'+  , mname    = "peekSkirmish"+  , mfreq    = [("peekSkirmish", 1)]+  , mplayers = playersPeekSkirmish+  , mcaves   = cavesCombat+  }+++playersCampaign, playersSkirmish, playersBattle, playersPvP, playersCoop, playersDefense, playersTestCampaign, playersTestSkirmish, playersTestBattle, playersTestPvP, playersTestCoop, playersTestDefense, playersPeekCampaign, playersPeekSkirmish :: Players++playersCampaign = Players+  { playersList = [ playerHero {playerInitial = 1}+                  , playerMonster ]+  , playersEnemy = [("Adventurer Party", "Monster Hive")]+  , playersAlly = [] }++playersSkirmish = Players+  { playersList = [ playerHero {playerName = "White"}+                  , playerAntiHero {playerName = "Purple"}+                  , playerHorror ]+  , playersEnemy = [ ("White", "Purple")+                   , ("White", "Horror Den")+                   , ("Purple", "Horror Den") ]+  , playersAlly = [] }++playersBattle = Players+  { playersList = [ playerHero {playerInitial = 5}+                  , playerMonster { playerInitial = 30+                                  , playerSpawn = 0 } ]+  , playersEnemy = [("Adventurer Party", "Monster Hive")]+  , 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+                                  , 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") ] }++playersTestCampaign = playersCampaign+  { playersList = [ playerHero { playerInitial = 5+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerMonster ] }++playersTestSkirmish = playersSkirmish+  { playersList = [ playerHero { playerName = "White"+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerAntiHero { playerName = "Purple" }+                  , playerHorror ] }++playersTestBattle = playersBattle+  { playersList = [ playerHero { playerInitial = 5+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerMonster { playerInitial = 30+                                  , playerSpawn = 0 } ] }++playersTestPvP = playersPvP+  { playersList = [ playerHero { playerName = "Red"+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerHero { playerName = "Blue"+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerHorror ] }++playersTestCoop = playersCoop+  { playersList = [ playerHero { playerName = "Coral"+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerHero { playerName = "Amber"+                               , playerAiLeader = True+                               , playerHuman = False }+                  , playerMonster ] }++playersTestDefense = playersDefense+  { playersList = [ playerMonster { playerInitial = 1+                                  , playerUI = True }+                  , playerAntiHero {playerName = "Green"}+                  , playerAntiHero {playerName = "Yellow"}+                  , playerAntiHero {playerName = "Cyan"} ] }++playersPeekCampaign = playersCampaign+  { playersList = [ playerHero {playerInitial = 1}+                  , playerMonster {playerUI = True} ] }++playersPeekSkirmish = playersSkirmish+  { playersList = [ playerHero {playerName = "White"}+                  , playerAntiHero { playerName = "Purple"+                                   , playerUI = True }+                  , playerHorror ] }+++playerHero, playerAntiHero, playerMonster, playerHorror :: Player++playerHero = Player+  { playerName = "Adventurer Party"+  , playerFaction = "hero"+  , playerSpawn = 0+  , 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"+  , playerSpawn = 50+  , playerEntry = toEnum (-3)+  , playerInitial = 5+  , playerAiLeader = True+  , playerAiOther = True+  , playerHuman = False+  , playerUI = False+  }++playerHorror = Player+  { playerName = "Horror Den"+  , playerFaction = "horror"+  , playerSpawn = 0+  , playerEntry = toEnum (-1)+  , playerInitial = 0+  , playerAiLeader = True+  , playerAiOther = True+  , playerHuman = False+  , playerUI = False+  }+++cavesCampaign, cavesCombat, cavesBattle :: 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))]++cavesBattle = EM.fromList [(toEnum (-3), ("caveBattle", Nothing))]
+ GameDefinition/Content/PlaceKind.hs view
@@ -0,0 +1,71 @@+-- | Rooms, halls and passages for LambdaHack.+module Content.PlaceKind ( cdefs ) where++import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Content.PlaceKind++cdefs :: ContentDef PlaceKind+cdefs = ContentDef+  { getSymbol = psymbol+  , getName = pname+  , getFreq = pfreq+  , validate = validatePlaceKind+  , content =+      [rect, pillar, pillarC, pillar3, colonnade, colonnadeW]+  }+rect,        pillar, pillarC, pillar3, colonnade, colonnadeW :: PlaceKind++rect = PlaceKind  -- Valid for any nonempty area, hence low frequency.+  { psymbol  = 'r'+  , pname    = "room"+  , pfreq    = [("rogue", 100)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "--"+               , "|."+               ]+  }+pillar = PlaceKind+  { psymbol  = 'p'+  , pname    = "pillar room"+  , pfreq    = [("rogue", 1000)]  -- larger rooms require support pillars+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|...."+               , "|.O.."+               , "|...."+               , "|...."+               ]+  }+pillarC = pillar+  { ptopLeft = [ "-----"+               , "|O..."+               , "|...."+               , "|...."+               , "|...."+               ]+  }+pillar3 = pillar+  { ptopLeft = [ "-----"+               , "|&.O."+               , "|...."+               , "|O..."+               , "|...."+               ]+  }+colonnade = PlaceKind+  { psymbol  = 'c'+  , pname    = "colonnade"+  , pfreq    = [("rogue", 500)]+  , pcover   = CAlternate+  , pfence   = FFloor+  , ptopLeft = [ "O."+               , ".O"+               ]+  }+colonnadeW = colonnade+  { ptopLeft = [ "O."+               , ".."+               ]+  }
+ GameDefinition/Content/RuleKind.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Game rules and assorted game setup data for LambdaHack.+module Content.RuleKind ( cdefs ) where++import Control.Arrow (first)+import Language.Haskell.TH.Syntax+import System.FilePath++-- Cabal+import qualified Paths_LambdaHack as Self (getDataFileName, version)++import Game.LambdaHack.Common.ContentDef+import qualified Game.LambdaHack.Common.Effect as Effect+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.HumanCmd+import qualified Game.LambdaHack.Common.Key as K+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.RuleKind++cdefs :: ContentDef RuleKind+cdefs = ContentDef+  { getSymbol = rsymbol+  , getName = rname+  , getFreq = rfreq+  , validate = validateRuleKind+  , content =+      [standard]+  }++standard :: RuleKind+standard = RuleKind+  { rsymbol        = 's'+  , rname          = "standard LambdaHack ruleset"+  , rfreq          = [("standard", 100)]+  -- Check whether one position is accessible from another.+  -- Precondition: the two positions are next to each other.+  -- Apart of checking the target tile, we forbid diagonal movement+  -- to and from doors.+  , raccessible    = Nothing+  , raccessibleDoor = Just $ \spos tpos ->+                                not $ isDiagonal $ 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 file+  -- included from config.ui.default.+  , rcfgUIName = "config.ui"+  , rcfgUIDefault = $(do+      let path = "GameDefinition" </> "config.ui" <.> "default"+      qAddDependentFile path+      x <- qRunIO (readFile path)+      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 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. 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: Show highlighted keybinding in inverse video or bright white on grey+  -- background. The spaces that pad keybindings are not highlighted.+  , rmainMenuArt = $(do+      let path = "GameDefinition/MainMenu.ascii"+      qAddDependentFile path+      x <- qRunIO (readFile path)+      lift x)+  , rhumanCommands = map (first K.mkKM)+      -- All commands are defined here, except some movement and leader picking+      -- commands. All commands are shown on help screens except debug commands+      -- and macros with empty descriptions.+      -- The order below determines the order on the help screens.+      -- Remember to put commands that show information (e.g., enter targeting+      -- mode) first.++      -- Main Menu, which apart of these includes a few extra commands+      [ ("CTRL-x", (CmdMenu, GameExit))+      , ("CTRL-r", (CmdMenu, GameRestart "campaign"))+      , ("CTRL-k", (CmdMenu, GameRestart "skirmish"))+      , ("CTRL-v", (CmdMenu, GameRestart "PvP"))+      , ("CTRL-o", (CmdMenu, GameRestart "Coop"))+      , ("CTRL-e", (CmdMenu, GameRestart "defense"))+      , ("CTRL-d", (CmdMenu, GameDifficultyCycle))++      -- Movement and terrain alteration+      , ("less", (CmdMove, TriggerTile+           [ TriggerFeature { verb = "ascend"+                            , object = "a level"+                            , feature = F.Cause (Effect.Ascend 1) }+           , TriggerFeature { verb = "escape"+                            , object = "dungeon"+                            , feature = F.Cause (Effect.Escape 1) } ]))+      , ("CTRL-less", (CmdMove, TriggerTile+           [ TriggerFeature { verb = "ascend"+                            , object = "10 levels"+                            , feature = F.Cause (Effect.Ascend 10) } ]))+      , ("greater", (CmdMove, TriggerTile+           [ TriggerFeature { verb = "descend"+                            , object = "a level"+                            , feature = F.Cause (Effect.Ascend (-1)) }+           , TriggerFeature { verb = "escape"+                            , object = "dungeon"+                            , feature = F.Cause (Effect.Escape (-1)) } ]))+      , ("CTRL-greater", (CmdMove, TriggerTile+           [ TriggerFeature { verb = "descend"+                            , object = "10 levels"+                            , feature = F.Cause (Effect.Ascend (-10)) } ]))+      , ("CTRL-semicolon", (CmdMove, StepToTarget))+      , ("semicolon", (CmdMove, Macro "go to target for 100 steps"+                                      ["CTRL-semicolon", "P"]))+      , ("x", (CmdMove, Macro "explore the closest unknown spot"+                              [ "BackSpace"+                              , "CTRL-question", "CTRL-semicolon", "P" ]))+      , ("X", (CmdMove, Macro "autoexplore 100 times"+                              [ "BackSpace"+                              , "'", "CTRL-question", "CTRL-semicolon", "'"+                              , "P" ]))+      , ("R", (CmdMove, Macro "rest (wait 100 times)" ["KP_Begin", "P"]))+      , ("c", (CmdMove, AlterDir+           [ AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "vertical closed door Lit" }+           , AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "horizontal closed door Lit" }+           , AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "vertical closed door Dark" }+           , AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "horizontal closed door Dark" }+           ]))+      , ("o", (CmdMove, AlterDir+           [ AlterFeature { verb = "open"+                          , object = "door"+                          , feature = F.OpenTo "vertical open door Lit" }+           , AlterFeature { verb = "open"+                          , object = "door"+                          , feature = F.OpenTo "horizontal open door Lit" }+           , AlterFeature { verb = "open"+                          , object = "door"+                          , feature = F.OpenTo "vertical open door Dark" }+           , AlterFeature { verb = "open"+                          , object = "door"+                          , feature = F.OpenTo "horizontal open door Dark" }+           ]))++      -- Inventory and items+      , ("I", (CmdItem, Inventory))+      , ("g", (CmdItem, Pickup))+      , ("d", (CmdItem, Drop))+      , ("q", (CmdItem, Apply [ApplyItem { verb = "quaff"+                                         , object = "potion"+                                         , symbol = '!' }]))+      , ("r", (CmdItem, Apply [ApplyItem { verb = "read"+                                         , object = "scroll"+                                         , symbol = '?' }]))+      , ("t", (CmdItem, Project [ApplyItem { verb = "throw"+                                           , object = "missile"+                                           , symbol = '|' }]))+      , ("z", (CmdItem, Project [ApplyItem { verb = "zap"+                                           , object = "wand"+                                           , symbol = '/' }]))++      -- Targeting+      , ("asterisk", (CmdTgt, TgtEnemy))+      , ("slash", (CmdTgt, TgtFloor))+      , ("plus", (CmdTgt, EpsIncr True))+      , ("minus", (CmdTgt, EpsIncr False))+      , ("BackSpace", (CmdTgt, TgtClear))+      , ("CTRL-question", (CmdTgt, TgtUnknown))+      , ("CTRL-I", (CmdTgt, TgtItem))+      , ("CTRL-braceleft", (CmdTgt, TgtStair True))+      , ("CTRL-braceright", (CmdTgt, TgtStair False))++      -- Assorted+      , ("question", (CmdMeta, Help))+      , ("D", (CmdMeta, History))+      , ("T", (CmdMeta, MarkSuspect))+      , ("V", (CmdMeta, MarkVision))+      , ("S", (CmdMeta, MarkSmell))+      , ("Tab", (CmdMeta, MemberCycle))+      , ("ISO_Left_Tab", (CmdMeta, MemberBack))+      , ("equal", (CmdMeta, SelectActor))+      , ("underscore", (CmdMeta, SelectNone))+      , ("p", (CmdMeta, Repeat 1))+      , ("P", (CmdMeta, Repeat 100))+      , ("CTRL-p", (CmdMeta, Repeat 1000))+      , ("apostrophe", (CmdMeta, Record))+      , ("space", (CmdMeta, Clear))+      , ("Escape", (CmdMeta, Cancel))+      , ("Return", (CmdMeta, Accept))++      -- Debug and others not to display in help screens+      , ("CTRL-s", (CmdDebug, GameSave))+      , ("CTRL-y", (CmdDebug, Resend))+      ]+  , rfirstDeathEnds = False+  , rfovMode = Digital 12+  , rsaveBkpClips = 500+  , rleadLevelClips = 100+  , rscoresFile = "scores"+  , rsavePrefix = "save"+  }
+ GameDefinition/Content/TileKind.hs view
@@ -0,0 +1,260 @@+-- | Terrain tiles for LambdaHack.+module Content.TileKind ( cdefs ) where++import Control.Arrow (first)+import Data.Text (Text)+import qualified Data.Text as T++import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.ContentDef+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Feature+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Content.TileKind++cdefs :: ContentDef TileKind+cdefs = ContentDef+  { getSymbol = tsymbol+  , getName = tname+  , getFreq = tfreq+  , validate = validateTileKind+  , content =+      [wall, hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit]+      ++ map makeDark [wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsLit, escapeUpLit, escapeDownLit, floorCorridorLit]+      ++ map makeDarkColor [stairsUpLit, stairsDownLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit]+  }+wall,        hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind++wall = TileKind+  { tsymbol  = ' '+  , tname    = "bedrock"+  , tfreq    = [("fillerWall", 1), ("legendLit", 100), ("legendDark", 100)]+  , tcolor   = defBG+  , tcolor2  = defBG+  , tfeature = [Dark]+  }+hardRock = TileKind+  { tsymbol  = ' '+  , tname    = "impenetrable bedrock"+  , tfreq    = [("basic outer fence", 1)]+  , tcolor   = BrWhite+  , tcolor2  = BrWhite+  , tfeature = [Dark, Impenetrable]+  }+pillar = TileKind+  { tsymbol  = 'O'+  , tname    = "rock"+  , tfreq    = [ ("cachable", 70)+               , ("legendLit", 100), ("legendDark", 100)+               , ("noiseSet", 55), ("combatSet", 3), ("battleSet", 9) ]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = []+  }+pillarCache = TileKind+  { tsymbol  = '&'+  , tname    = "cache"+  , tfreq    = [ ("cachable", 30)+               , ("legendLit", 100), ("legendDark", 100) ]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Suspect, Cause $ Effect.CreateItem 1, ChangeTo "cachable"]+  }+tree = TileKind+  { tsymbol  = 'O'+  , tname    = "tree"+  , tfreq    = [("combatSet", 8)]+  , tcolor   = BrGreen+  , tcolor2  = Green+  , tfeature = []+  }+wallV = TileKind+  { tsymbol  = '|'+  , tname    = "granite wall"+  , tfreq    = [("legendLit", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [HideAs "suspect vertical wall Lit"]+  }+wallSuspectV = TileKind+  { tsymbol  = '|'+  , tname    = "moldy wall"+  , tfreq    = [("suspect vertical wall Lit", 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Suspect, RevealAs "vertical closed door Lit"]+  }+doorClosedV = TileKind+  { tsymbol  = '+'+  , tname    = "closed door"+  , tfreq    = [("vertical closed door Lit", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ OpenTo "vertical open door Lit"+               , HideAs "suspect vertical wall Lit"+               ]+  }+doorOpenV = TileKind+  { tsymbol  = '-'+  , tname    = "open door"+  , tfreq    = [("vertical open door Lit", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ Walkable, Clear+               , CloseTo "vertical closed door Lit"+               ]+  }+wallH = TileKind+  { tsymbol  = '-'+  , tname    = "granite wall"+  , tfreq    = [("legendLit", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [HideAs "suspect horizontal wall Lit"]+  }+wallSuspectH = TileKind+  { tsymbol  = '-'+  , tname    = "scratched wall"+  , tfreq    = [("suspect horizontal wall Lit", 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Suspect, RevealAs "horizontal closed door Lit"]+  }+doorClosedH = TileKind+  { tsymbol  = '+'+  , tname    = "closed door"+  , tfreq    = [("horizontal closed door Lit", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ OpenTo "horizontal open door Lit"+               , HideAs "suspect horizontal wall Lit"+               ]+  }+doorOpenH = TileKind+  { tsymbol  = '|'+  , tname    = "open door"+  , tfreq    = [("horizontal open door Lit", 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , tfeature = [ Walkable, Clear+               , CloseTo "horizontal closed door Lit"+               ]+  }+stairsUpLit = TileKind+  { tsymbol  = '<'+  , tname    = "staircase up"+  , tfreq    = [("legendLit", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Walkable, Clear, Cause $ Effect.Ascend 1]+  }+stairsLit = TileKind+  { tsymbol  = '>'+  , tname    = "staircase"+  , tfreq    = [("legendLit", 100)]+  , tcolor   = BrCyan+  , tcolor2  = Cyan  -- TODO+  , tfeature = [ Walkable, Clear+               , Cause $ Effect.Ascend 1+               , Cause $ Effect.Ascend (-1) ]+  }+stairsDownLit = TileKind+  { tsymbol  = '>'+  , tname    = "staircase down"+  , tfreq    = [("legendLit", 100)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Walkable, Clear, Cause $ Effect.Ascend (-1)]+  }+escapeUpLit = TileKind+  { tsymbol  = '<'+  , tname    = "exit trapdoor up"+  , tfreq    = [("legendLit", 100)]+  , tcolor   = BrYellow+  , tcolor2  = BrYellow+  , tfeature = [Walkable, Clear, Cause (Effect.Escape 1)]+  }+escapeDownLit = TileKind+  { tsymbol  = '>'+  , tname    = "exit trapdoor down"+  , tfreq    = [("legendLit", 100)]+  , tcolor   = BrYellow+  , tcolor2  = BrYellow+  , tfeature = [Walkable, Clear, Cause (Effect.Escape (-1))]+  }+unknown = TileKind+  { tsymbol  = ' '+  , tname    = "unknown space"+  , tfreq    = [("unknown space", 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , tfeature = [Dark]+  }+floorCorridorLit = TileKind+  { tsymbol  = '#'+  , tname    = "corridor"+  , tfreq    = [("floorCorridorLit", 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , tfeature = [Walkable, Clear]+  }+floorArenaLit = floorCorridorLit+  { tsymbol  = '.'+  , tname    = "stone floor"+  , tfreq    = [ ("floorArenaLit", 1)+               , ("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100) ]+  }+floorActorLit = floorArenaLit+  { tfreq    = [("floorActorLit", 1), ("battleSet", 100)]+  , tfeature = CanActor : tfeature floorArenaLit+  }+floorItemLit = floorArenaLit+  { tfreq    = []+  , tfeature = CanItem : tfeature floorArenaLit+  }+floorActorItemLit = floorItemLit+  { tfreq    = [("legendLit", 100), ("emptySet", 1)]+  , tfeature = CanActor : tfeature floorItemLit+  }+floorRedLit = floorArenaLit+  { tname    = "brick pavement"+  , tfreq    = [("trailLit", 30)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , tfeature = Trail : tfeature floorArenaLit+  }+floorBlueLit = floorRedLit+  { tname    = "granite cobblestones"+  , tfreq    = [("trailLit", 100)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  }+floorGreenLit = floorRedLit+  { tname    = "mossy stone path"+  , tfreq    = [("trailLit", 100)]+  , tcolor   = BrGreen+  , tcolor2  = Green+  }+floorBrownLit = floorRedLit+  { tname    = "rotting mahogany deck"+  , tfreq    = [("trailLit", 10)]+  , tcolor   = BrMagenta+  , tcolor2  = Magenta+  }++makeDark :: TileKind -> TileKind+makeDark k = let textLit :: Text -> Text+                 textLit t = maybe t (<> "Dark") $ T.stripSuffix "Lit" t+                 litFreq = map (first textLit) $ tfreq k+                 litFeat (OpenTo t) = OpenTo $ textLit t+                 litFeat (CloseTo t) = CloseTo $ textLit t+                 litFeat (ChangeTo t) = ChangeTo $ textLit t+                 litFeat (HideAs t) = HideAs $ textLit t+                 litFeat (RevealAs t) = RevealAs $ textLit t+                 litFeat feat = feat+             in k { tfreq    = litFreq+                  , tfeature = Dark : map litFeat (tfeature k)+                  }++makeDarkColor :: TileKind -> TileKind+makeDarkColor k = (makeDark k) {tcolor2 = BrBlack}
+ GameDefinition/Main.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | 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++import qualified Content.ActorKind+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.TileKind+import Game.LambdaHack.Client+import Game.LambdaHack.Client.Action.ActionType+import Game.LambdaHack.Common.Action (MonadAtomic (..))+import Game.LambdaHack.Common.AtomicCmd+import Game.LambdaHack.Common.AtomicSem+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Server+import Game.LambdaHack.Server.Action.ActionType+import Game.LambdaHack.Server.AtomicSemSer++-- | The game-state semantics of atomic game commands+-- as computed on the server.+instance MonadAtomic ActionSer where+  execAtomic = atomicSendSem++-- | The game-state semantics of atomic game commands+-- as computed on clients. Special effects (@SfxAtomic@) don't modify state.+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+        { coactor   = Kind.createOps Content.ActorKind.cdefs+        , cocave    = Kind.createOps Content.CaveKind.cdefs+        , cofaction = 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+        , cotile    = Kind.createOps Content.TileKind.cdefs+        }+  in mainSer copsSlow executorSer $ exeFrontend executorCli executorCli
+ GameDefinition/MainMenu.ascii view
@@ -0,0 +1,26 @@+----------------------------------------------------------------------------------+|                                                                                |+|                      >> LambdaHack <<                                          |+|                                                                                |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |+|                                                                                |+|                                                                                |+|                        Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) |+----------------------------------------------------------------------------------
+ GameDefinition/PLAYING.md view
@@ -0,0 +1,204 @@+Playing LambdaHack+==================++LambdaHack is a small dungeon crawler illustrating the roguelike game engine+library also called LambdaHack. Playing the game involves walking around+the dungeon, alone or in a party of fearless adventurers, setting up ambushes,+hiding in shadow, covering tracks, breaking through to deeper caves,+bumping into monsters, doors and walls, gathering magical treasure+and making creative use of it. The bloodthirsty monsters do the same,+intelligence allowing, while tirelessly chasing the elusive heroes+by smell and sight.++Once the few basic command keys and on-screen symbols are learned,+mastery and enjoyment of the game is the matter of tactical skill+and literary imagination. To be honest, a lot of imagination is required+for this rudimentary game, but it's playable and winnable.+The game also features experimental multiplayer cooperative and competitive+modes, but they are troublesome to play with the shared-screen+and shared-keyboard interface available at this time.+Contributions welcome.+++Dungeon+-------++The heroes are marked on the map with symbols `@` and `1` through `9`.+Their goal is to explore the dungeon, battle the horrors within,+gather as much gold and gems as possible, and escape to tell the tale.+The dungeon of the campaign mode game consists of 10 levels and each level+consists of a large number of tiles. The basic tile kinds are as follows.++               dungeon terrain type               on-screen symbol+               floor                              .+               corridor                           #+               wall (horizontal and vertical)     - and |+               rock or tree                       O+               cache                              &+               stairs up                          <+               stairs down                        >+               open door                          | and -+               closed door                        ++               bedrock                            blank++The game world is persistent, i.e., every time the player visits a level+during a single game, the level layout is the same.+++Keys+----++You move throughout the level using the numerical keypad or+the vi text editor keys (also known as "Rogue-like keys").++                7 8 9          y k u+                 \|/            \|/+                4-5-6          h-.-l+                 /|\            /|\+                1 2 3          b j n++`SHIFT` (or `CTRL`) and a movement key make the current party leader+(and currently selected party members, if any) run in the indicated+direction, until anything of interest is spotted.+The `5` and `.` keys consume a turn and make you brace for combat,+which confers a chance to block blows for the remainder of the turn.+In targeting mode the same keys move the targeting cursor.++Melee, searching for secret doors and opening closed doors+can be done by bumping into a monster, a wall and a door, respectively.+Few commands other than movement are necessary for casual play.+Some are provided only as building blocks for more complex convenience+commands, e.g., the autoexplore command (key `X`) could be defined+by the player as a macro using `BACKSPACE`, `CTRL-?`, `CTRL-;` and `P`.++Below are the remaining keys for movement and terrain alteration.++                keys           command+                <              ascend a level+                CTRL-<         ascend 10 levels+                >              descend a level+                CTRL->         descend 10 levels+                CTRL-;         make one step towards the target+                ;              go to target for 100 steps+                x              explore the closest unknown spot+                X              autoexplore 100 times+                R              rest (wait 100 times)+                c              close door+                o              open door++Inventory and items-related keys are as follows.++                keys           command+                I              display inventory+                g and ,        get an object+                d              drop an object+                q              quaff potion+                r              read scroll+                t              throw missile+                z              zap wand++To make a ranged attack, as in the last few commands above,+you need to set your target first (however, initial target is set+automatically as soon as a monster comes into view). Once in targeting mode,+you can move the targeting cursor with arrow keys and switch focus+among enemies with `*` (or among friends and enemies, depending+on targeting mode set by `/`). The details of the shared cursor position+and of the personal target are described at the bottom of the screen.+All targeting keys are listed below.++                keys           command+                *              target enemy+                /              cycle targeting mode+                +              swerve targeting line+                -              unswerve targeting line+                BACKSPACE      clear target/cursor+                CTRL-?         target the closest unknown spot+                CTRL-I         target the closest item+                CTRL-{         target the closest stairs up+                CTRL-}         target the closest stairs down++Assorted remaining keys and commands follow.++                keys           command+                ?              display help+                D              display player diary+                T              mark suspect terrain+                V              mark visible area+                S              mark smell+                TAB            cycle among party members on the level+                SHIFT-TAB      cycle among party members in the dungeon+                =              select (or deselect) a party member+                _              deselect (or select) all on the level+                p              play back last keys+                P              play back last keys 100 times+                CTRL-p         play back last keys 1000 times+                '              start recording a macro+                SPACE          clear messages+                ESC            cancel action+                RET            accept choice+                0--9           pick a new hero leader anywhere in the dungeon++Commands for saving and exiting the current game, starting a new game, etc.,+are listed in the Main Menu, brought up by the `ESC` key.+All but the campaign and skirmish game modes are experimental+and feature multiple human or computer players (allied or not).+Game difficulty setting affects hitpoints at birth for any actors+of any UI-using faction.++                keys           command+                CTRL-x         save and exit+                CTRL-r         new campaign game+                CTRL-k         new skirmish game+                CTRL-v         new PvP game+                CTRL-o         new Coop game+                CTRL-e         new defense game+                CTRL-d         cycle next game difficulty++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 test --gameMode testCampaign --difficulty 1+++Monsters+--------++Heroes are not alone in the dungeon. Monsters roam the dark caves+and crawl from damp holes day and night. While heroes pay attention+to all other party members and take care to move one at a time,+monsters don't care about each other and all move at once,+sometimes brutally colliding by accident.++When the hero bumps into a monster or a monster attacks the hero,+melee combat occurs. The best weapon carried by each opponent+is taken into account for calculating bonus damage. The total damage+the current hero can potentially inflict is displayed at the bottom+of the screen. The total damage potential of a monster may change+as it finds and picks up new weapons. Heroes and monsters running into+one another (with the `SHIFT` key) do not inflict damage, but change places.+This gives the opponent a free blow, but can improve the tactical situation+or aid escape.++Throwing weapons at targets wounds them, consuming the weapon in the process.+You may throw any object in your possession (press `?` to choose+an object and press it again for a non-standard choice) or on the floor+(press `-`). Only objects of a few kinds inflict any damage.+Whenever the monster's or hero's hit points reach zero, the combatant dies.+When the last hero dies, the game ends.+++On Winning and Dying+--------------------++You win the game if you escape the dungeon alive (or eliminate+all opposition, in some game modes). Your score is+the sum of all gold you've plundered plus 100 gold pieces for each gem.+Only the loot in possession of the party members on the current level+counts (the rest of the party is considered MIA).++If all heroes die, your score is halved and only the treasure carried+by the last standing hero counts. You are free to start again+from a different entrance to the dungeon, but all your previous wealth+is gone and fresh, undaunted enemies bar your way.
+ GameDefinition/config.ui.default view
@@ -0,0 +1,26 @@+; ; This is a commented out copy of the default UI settings config file+; ; that is embedded in the binary.+; ; A user config file can overrides these options. The game looks for it at+; ; ~/.LambdaHack/config.ui.ini (or a similar path, depending on the OS).+; ; Warning: options are case-sensitive and only ';' for comments is permitted.++; [extra_commands]+; ; Handy shorthands with Vi keys:+; Macro_1 = ("comma", (CmdItem, Macro "" ["g"]))+; Macro_2 = ("period", (CmdMove, Macro "" ["KP_Begin"]))++; [hero_names]+; HeroName_0 = Haskell Alvin+; HeroName_1 = Alonzo Barkley+; HeroName_2 = Ines Galenti+; HeroName_3 = Ernst Abraham+; HeroName_4 = Samuel Saunders+; HeroName_5 = Roger Robin++; [ui]+; font = "Terminus,Monospace normal normal normal normal 12"+; historyMax = 5000+; maxFps = 15+; noAnim = False+; runStopMsgs = False+[dummy]
+ GameDefinition/scores view

binary file changed (absent → 188 bytes)

LICENSE view
@@ -1,5 +1,5 @@-Copyright (c) 2008--2013 Andres Loeh-Copyright (c) 2010--2013 Mikolaj Konarski+Copyright (c) 2008--2014 Andres Loeh+Copyright (c) 2010--2014 Mikolaj Konarski  All rights reserved.
LambdaHack.cabal view
@@ -1,5 +1,5 @@ name:          LambdaHack-version:       0.2.10.6+version:       0.2.12 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@@ -15,20 +15,11 @@                but the fundamental source of flexibility lies                in the strict and type-safe separation of code and content                and of clients (human and AI-controlled) and server.-               .-               This is a minor release, primarily intended to fix broken-               vty an curses frontends and an unrelated game crash, as well as-               broken builds on hackage and travis. Changes since 0.2.10-               are mostly unrelated to gameplay: overhauled dungeon generation-               code and the use of the external library assert-failure-               for expressing assertions and error messages.-               Upcoming features: new and improved frontends, improved AI-               (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-               based on player behaviour.+               Please see the changelog file for recent improvements+               and the issue tracker for short-term plans. Long term vision+               revolves around procedural content generation and includes+               in-game content creation, auto-balancing and persistent+               content modification based on player behaviour.                .                A larger game that depends on the LambdaHack library                is Allure of the Stars, available from@@ -49,10 +40,11 @@ bug-reports:   http://github.com/kosmikus/LambdaHack/issues license:       BSD3 license-file:  LICENSE-tested-with:   GHC == 7.4.2, GHC == 7.6.3, GHC == 7.7-data-files:    config.rules.default, config.ui.default, scores-extra-source-files: LICENSE, CREDITS, changelog, PLAYING.md, README.md,-                    Makefile, MainMenu.ascii, .travis.yml+tested-with:   GHC == 7.6.3, GHC == 7.8+data-files:    GameDefinition/config.ui.default,+               GameDefinition/scores+extra-source-files: GameDefinition/PLAYING.md, GameDefinition/MainMenu.ascii,+                    README.md, LICENSE, CREDITS, changelog, Makefile author:        Andres Loeh, Mikolaj Konarski maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com> category:      Game Engine, Game@@ -81,7 +73,6 @@                       Game.LambdaHack.Client.ClientSem,                       Game.LambdaHack.Client.Config,                       Game.LambdaHack.Client.Draw,-                      Game.LambdaHack.Client.HumanCmd,                       Game.LambdaHack.Client.HumanGlobal,                       Game.LambdaHack.Client.HumanLocal,                       Game.LambdaHack.Client.HumanSem,@@ -100,22 +91,23 @@                       Game.LambdaHack.Common.AtomicSem,                       Game.LambdaHack.Common.ClientCmd,                       Game.LambdaHack.Common.Color,-                      Game.LambdaHack.Common.ConfigIO,                       Game.LambdaHack.Common.ContentDef,                       Game.LambdaHack.Common.Effect,                       Game.LambdaHack.Common.Faction,                       Game.LambdaHack.Common.Feature,                       Game.LambdaHack.Common.Flavour,                       Game.LambdaHack.Common.HighScore,+                      Game.LambdaHack.Common.HumanCmd,                       Game.LambdaHack.Common.Item,+                      Game.LambdaHack.Common.ItemFeature,                       Game.LambdaHack.Common.Key,                       Game.LambdaHack.Common.Kind,                       Game.LambdaHack.Common.Level,                       Game.LambdaHack.Common.Misc,                       Game.LambdaHack.Common.Msg,                       Game.LambdaHack.Common.Perception,+                      Game.LambdaHack.Common.PointArray,                       Game.LambdaHack.Common.Point,-                      Game.LambdaHack.Common.PointXY,                       Game.LambdaHack.Common.Random,                       Game.LambdaHack.Common.Save,                       Game.LambdaHack.Common.ServerCmd,@@ -123,7 +115,6 @@                       Game.LambdaHack.Common.Tile,                       Game.LambdaHack.Common.Time,                       Game.LambdaHack.Common.Vector,-                      Game.LambdaHack.Common.VectorXY,                       Game.LambdaHack.Content.ActorKind,                       Game.LambdaHack.Content.CaveKind,                       Game.LambdaHack.Content.FactionKind,@@ -140,7 +131,6 @@                       Game.LambdaHack.Server.Action.ActionClass,                       Game.LambdaHack.Server.Action.ActionType,                       Game.LambdaHack.Server.AtomicSemSer,-                      Game.LambdaHack.Server.Config,                       Game.LambdaHack.Server.DungeonGen,                       Game.LambdaHack.Server.DungeonGen.Area                       Game.LambdaHack.Server.DungeonGen.AreaRnd,@@ -161,8 +151,7 @@                       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,+  build-depends:      array      >= 0.3.0.3 && < 1,                       assert-failure >= 0.1 && < 1,                       base       >= 4       && < 5,                       binary     >= 0.7     && < 1,@@ -173,17 +162,20 @@                       enummapset-th >= 0.6.0.0 && < 1,                       filepath   >= 1.2.0.1 && < 2,                       ghc-prim   >= 0.2,-                      hashable   >= 1.2     && < 2,+                      hashable   >= 1.1.2.5 && < 2,+                      hsini      >= 0.2     && < 2,                       keys       >= 3       && < 4,                       miniutter  >= 0.4.1   && < 2,                       mtl        >= 2.0.1   && < 3,                       old-time   >= 1.0.0.7 && < 2,-                      pretty-show >= 1.6    && < 1.6.2,+                      pretty-show >= 1.6    && < 2,                       random     >= 1.0.1   && < 2,                       stm        >= 2.4     && < 3,                       text       >= 0.11.2.3 && < 2,                       transformers >= 0.3   && < 1,                       unordered-containers >= 0.2.3 && < 1,+                      vector     >= 0.10    && < 1,+                      vector-binary-instances >= 0.2 && < 1,                       zlib       >= 0.5.3.1 && < 1    default-language:   Haskell2010@@ -206,7 +198,7 @@     cpp-options:      -DCURSES   } else { if flag(vty) {     other-modules:    Game.LambdaHack.Frontend.Vty-    build-depends:    vty >= 4.7.0.6+    build-depends:    vty >= 4.7.0.6 && < 5     cpp-options:      -DVTY   } else {     other-modules:    Game.LambdaHack.Frontend.Gtk@@ -214,7 +206,7 @@   } }  executable LambdaHack-  hs-source-dirs:     LambdaHack+  hs-source-dirs:     GameDefinition   main-is:            Main.hs   other-modules:      Content.ActorKind,                       Content.CaveKind,@@ -228,7 +220,6 @@   build-depends:      LambdaHack,                       template-haskell >= 2.6 && < 3, -                      ConfigFile >= 1.1.1   && < 2,                       array      >= 0.3.0.3 && < 1,                       assert-failure >= 0.1 && < 1,                       base       >= 4       && < 5,@@ -240,16 +231,20 @@                       enummapset-th >= 0.6.0.0 && < 1,                       filepath   >= 1.2.0.1 && < 2,                       ghc-prim   >= 0.2,-                      hashable   >= 1.2     && < 2,+                      hashable   >= 1.1.2.5 && < 2,+                      hsini      >= 0.2     && < 2,                       keys       >= 3       && < 4,                       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 && < 2,                       transformers >= 0.3   && < 1,                       unordered-containers >= 0.2.3 && < 1,+                      vector     >= 0.10    && < 1,+                      vector-binary-instances >= 0.2 && < 1,                       zlib       >= 0.5.3.1 && < 1    default-language:   Haskell2010
− LambdaHack/Content/ActorKind.hs 
@@ -1,88 +0,0 @@--- | Monsters and heroes for LambdaHack.-module Content.ActorKind ( cdefs ) where--import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ActorKind--cdefs :: ContentDef ActorKind-cdefs = ContentDef-  { getSymbol = asymbol-  , getName = aname-  , getFreq = afreq-  , validate = avalidate-  , content =-      [hero, projectile, eye, fastEye, nose]-  }-hero,        projectile, eye, fastEye, nose :: ActorKind--hero = ActorKind-  { asymbol = '@'-  , aname   = "hero"-  , afreq   = [("hero", 1)]-  , acolor  = BrWhite  -- modified if many hero factions-  , ahp     = rollDice 50 1-  , aspeed  = toSpeed 2-  , asight  = True-  , asmell  = False-  , aiq     = 15  -- higher that that leads to looping movement-  , aregen  = 500-  , acanDo  = [minBound..maxBound]-  }--projectile = ActorKind  -- includes homing missiles-  { asymbol = '*'-  , aname   = "projectile"-  , afreq   = [("projectile", 1)]  -- Does not appear randomly in the dungeon.-  , acolor  = BrWhite-  , ahp     = rollDice 0 0-  , aspeed  = toSpeed 0-  , asight  = False-  , asmell  = False-  , aiq     = 0-  , aregen  = maxBound-  , acanDo  = [Track]-  }--eye = ActorKind-  { asymbol = 'e'-  , aname   = "reducible eye"-  , afreq   = [("monster", 60), ("horror", 60)]-  , acolor  = BrRed-  , ahp     = rollDice 7 4-  , aspeed  = toSpeed 2-  , asight  = True-  , asmell  = False-  , aiq     = 8-  , aregen  = 100-  , acanDo  = [minBound..maxBound]-  }-fastEye = ActorKind-  { asymbol = 'e'-  , aname   = "super-fast eye"-  , afreq   = [("monster", 15), ("horror", 15)]-  , acolor  = BrBlue-  , ahp     = rollDice 1 4-  , aspeed  = toSpeed 4-  , asight  = True-  , asmell  = False-  , aiq     = 12-  , aregen  = 5  -- Regenerates fast (at max HP most of the time!).-  , acanDo  = [minBound..maxBound]-  }-nose = ActorKind-  { asymbol = 'n'-  , aname   = "point-free nose"-  , afreq   = [("monster", 20), ("horror", 20)]-  , acolor  = Green-  , ahp     = rollDice 17 2-  , aspeed  = toSpeed 1.8-  , asight  = False-  , asmell  = True-  , aiq     = 0-  , aregen  = 100-  , acanDo  = [minBound..maxBound]-  }
− LambdaHack/Content/CaveKind.hs 
@@ -1,116 +0,0 @@--- | Cave layouts for LambdaHack.-module Content.CaveKind ( cdefs ) where--import Data.Ratio--import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Random as Random-import Game.LambdaHack.Content.CaveKind--cdefs :: ContentDef CaveKind-cdefs = ContentDef-  { getSymbol = csymbol-  , getName = cname-  , getFreq = cfreq-  , validate = cvalidate-  , content =-      [rogue, arena, empty, noise, combat]-  }-rogue,        arena, empty, noise, combat :: CaveKind--rogue = CaveKind-  { csymbol       = '$'-  , cname         = "A maze of twisty passages"-  , cfreq         = [("dng", 100), ("caveRogue", 1)]-  , cxsize        = fst normalLevelBound + 1-  , cysize        = snd normalLevelBound + 1-  , cgrid         = rollDiceXY [(3, 2)] [(1, 2), (2, 1)]-  , cminPlaceSize = rollDiceXY [(2, 2), (2, 1)] [(4, 1)]-  , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound, 1)]-                               [(snd normalLevelBound, 1)]-  , cdarkChance   = rollDeep (1, 54) (0, 0)-  , cnightChance  = intToDeep 100-  , cauxConnects  = 1%3-  , cmaxVoid      = 1%6-  , cminStairDist = 30-  , cdoorChance   = 1%2-  , copenChance   = 1%10-  , chidden       = 8-  , citemNum      = rollDice 7 2-  , citemFreq     = [(70, "useful"), (30, "treasure")]-  , cdefTile        = "fillerWall"-  , cdarkCorTile    = "floorCorridorDark"-  , clitCorTile     = "floorCorridorDark"-  , cfillerTile     = "fillerWall"-  , cdarkLegendTile = "darkLegend"-  , clitLegendTile  = "litLegend"-  }-arena = rogue-  { csymbol       = 'A'-  , cname         = "Underground city"-  , cfreq         = [("dng", 30), ("caveArena", 1)]-  , cgrid         = rollDiceXY [(2, 2)] [(2, 2)]-  , cminPlaceSize = rollDiceXY [(2, 2), (3, 1)] [(4, 1)]-  , cdarkChance   = rollDeep (1, 80) (1, 60)-  , cnightChance  = intToDeep 0-  , cmaxVoid      = 1%3-  , chidden       = 1000-  , citemNum      = rollDice 5 2  -- few rooms-  , cdefTile      = "arenaSet"-  , cdarkCorTile  = "pathDark"-  , clitCorTile   = "pathLit"-  }-empty = rogue-  { csymbol       = '.'-  , cname         = "Tall cavern"-  , cfreq         = [("dng", 20), ("caveEmpty", 1)]-  , cgrid         = rollDiceXY [(1, 2), (1, 1)] [(1, 1)]-  , cminPlaceSize = rollDiceXY [(10, 1)] [(10, 1)]-  , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound * 3 `div` 5, 1)]-                               [(snd normalLevelBound * 3 `div` 5, 1)]-  , cdarkChance   = rollDeep (1, 80) (1, 80)-  , cnightChance  = intToDeep 0-  , cauxConnects  = 1-  , cmaxVoid      = 1%2-  , cminStairDist = 50-  , chidden       = 1000-  , citemNum      = rollDice 8 2  -- whole floor strewn with treasure-  , cdefTile      = "emptySet"-  , cdarkCorTile  = "pathDark"-  , clitCorTile   = "floorArenaLit"-  }-noise = rogue-  { csymbol       = '!'-  , cname         = "Glittering cave"-  , cfreq         = [("dng", 20), ("caveNoise", 1)]-  , cgrid         = rollDiceXY [(2, 2)] [(1, 2), (1, 1)]-  , cminPlaceSize = rollDiceXY [(3, 2), (2, 1)] [(5, 1)]-  , cdarkChance   = rollDeep (1, 80) (1, 40)-  , cnightChance  = rollDeep (1, 40) (1, 40)-  , cmaxVoid      = 0-  , chidden       = 1000-  , citemNum      = rollDice 4 2  -- fewer rooms-  , cdefTile      = "noiseSet"-  , cdarkCorTile  = "pathDark"-  , clitCorTile   = "pathLit"-  }-combat = rogue-  { csymbol       = 'C'-  , cname         = "Combat arena"-  , cfreq         = [("caveCombat", 1)]-  , cgrid         = rollDiceXY [(2, 2), (3, 1)] [(1, 2), (2, 1)]-  , cminPlaceSize = rollDiceXY [(3, 1)] [(3, 1)]-  , cmaxPlaceSize = rollDiceXY [(5, 1)] [(5, 1)]-  , cdarkChance   = intToDeep 100-  , cnightChance  = rollDeep (1, 67) (0, 0)-  , chidden       = 1000-  , cauxConnects  = 0-  , cdoorChance   = 1-  , copenChance   = 0-  , citemNum      = rollDice 12 2-  , citemFreq     = [(100, "useful")]-  , cdefTile      = "combatSet"-  , cdarkCorTile  = "pathLit"  -- for now, let paths give off light-  , clitCorTile   = "floorArenaLit"-  }
− LambdaHack/Content/FactionKind.hs 
@@ -1,55 +0,0 @@--- | 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--cdefs :: ContentDef FactionKind-cdefs = ContentDef-  { getSymbol = fsymbol-  , getName = fname-  , getFreq = ffreq-  , validate = fvalidate-  , content =-      [hero, monster, horror]-  }-hero,        monster, horror :: FactionKind--hero = FactionKind-  { fsymbol        = '@'-  , fname          = "hero"-  , ffreq          = [("hero", 1)]-  , fAbilityLeader = allAbilities-  , fAbilityOther  = meleeAdjacent-  }--monster = FactionKind-  { 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)]-  , 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 
@@ -1,206 +0,0 @@--- | Weapons and treasure for LambdaHack.-module Content.ItemKind ( cdefs ) where--import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Content.ItemKind--cdefs :: ContentDef ItemKind-cdefs = ContentDef-  { getSymbol = isymbol-  , getName = iname-  , getFreq = ifreq-  , validate = ivalidate-  , content =-      [amulet, dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle]-  }-amulet,        dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle :: ItemKind--gem, potion, scroll, wand :: ItemKind  -- generic templates---- castDeep (aDb, xDy) = castDice aDb + (lvl - 1) * castDice xDy / (depth - 1)--amulet = ItemKind-  { isymbol  = '"'-  , iname    = "amulet"-  , ifreq    = [("useful", 6)]-  , iflavour = zipFancy [BrGreen]-  , ieffect  = Regeneration (rollDeep (2, 3) (1, 10))-  , icount   = intToDeep 1-  , iverbApply   = "tear down"-  , iverbProject = "cast"-  , iweight  = 30-  , itoThrow = -50  -- not dense enough-  }-dart = ItemKind-  { isymbol  = '|'-  , iname    = "dart"-  , ifreq    = [("useful", 20)]-  , iflavour = zipPlain [Cyan]-  , ieffect  = Hurt (rollDice 1 1) (rollDeep (1, 2) (1, 2))-  , icount   = rollDeep (3, 3) (0, 0)-  , iverbApply   = "snap"-  , iverbProject = "hurl"-  , iweight  = 50-  , itoThrow = 0  -- a cheap dart-  }-gem = ItemKind-  { isymbol  = '*'-  , iname    = "gem"-  , ifreq    = [("treasure", 20)]  -- x3, but rare on shallow levels-  , iflavour = zipPlain brightCol  -- natural, so not fancy-  , ieffect  = NoEffect-  , icount   = intToDeep 0-  , iverbApply   = "crush"-  , iverbProject = "toss"-  , iweight  = 50-  , itoThrow = 0-  }-gem1 = gem-  { icount   = rollDeep (0, 0) (1, 1)  -- appears on max depth-  }-gem2 = gem-  { icount   = rollDeep (0, 0) (1, 2)  -- appears halfway-  }-gem3 = gem-  { icount   = rollDeep (0, 0) (1, 3)  -- appears early-  }-currency = ItemKind-  { isymbol  = '$'-  , iname    = "gold piece"-  , ifreq    = [("treasure", 20), ("currency", 1)]-  , iflavour = zipPlain [BrYellow]-  , ieffect  = NoEffect-  , icount   = rollDeep (0, 0) (10, 10)  -- appears on lvl 2-  , iverbApply   = "grind"-  , iverbProject = "toss"-  , iweight  = 31-  , itoThrow = 0-  }-harpoon = ItemKind-  { isymbol  = '|'-  , iname    = "harpoon"-  , ifreq    = [("useful", 25)]-  , iflavour = zipPlain [Brown]-  , ieffect  = Hurt (rollDice 1 2) (rollDeep (1, 2) (2, 2))-  , icount   = rollDeep (0, 0) (2, 2)-  , iverbApply   = "break up"-  , iverbProject = "hurl"-  , iweight  = 4000-  , itoThrow = 0  -- cheap but deadly-  }-potion = ItemKind-  { isymbol  = '!'-  , iname    = "potion"-  , ifreq    = [("useful", 15)]-  , iflavour = zipFancy stdCol-  , ieffect  = NoEffect-  , icount   = intToDeep 1-  , iverbApply   = "gulp down"-  , iverbProject = "lob"-  , iweight  = 200-  , itoThrow = -50  -- oily, bad grip-  }-potion1 = potion-  { ifreq    = [("useful", 5)]-  , ieffect  = ApplyPerfume-  }-potion2 = potion-  { ieffect  = Heal 5-  }-potion3 = potion-  { ifreq    = [("useful", 5)]-  , ieffect  = Heal (-5)-  }-ring = ItemKind-  { isymbol  = '='-  , iname    = "ring"-  , ifreq    = []  -- [("useful", 10)]  -- TODO: make it useful-  , iflavour = zipPlain [White]-  , ieffect  = Searching (rollDeep (1, 6) (3, 2))-  , icount   = intToDeep 1-  , iverbApply   = "squeeze down"-  , iverbProject = "toss"-  , iweight  = 15-  , itoThrow = 0-  }-scroll = ItemKind-  { isymbol  = '?'-  , iname    = "scroll"-  , ifreq    = [("useful", 4)]-  , iflavour = zipFancy darkCol  -- arcane and old-  , ieffect  = NoEffect-  , icount   = intToDeep 1-  , iverbApply   = "decipher"-  , iverbProject = "lob"-  , iweight  = 50-  , itoThrow = -75  -- bad shape, even rolled up-  }-scroll1 = scroll-  { ieffect  = CallFriend 1-  , ifreq    = [("useful", 2)]-  }-scroll2 = scroll-  { ieffect  = Summon 1-  }-scroll3 = scroll-  { ieffect  = Ascend (-1)-  }-sword = ItemKind-  { isymbol  = ')'-  , iname    = "sword"-  , ifreq    = [("useful", 40)]-  , iflavour = zipPlain [BrCyan]-  , ieffect  = Hurt (rollDice 3 1) (rollDeep (1, 2) (4, 2))-  , icount   = intToDeep 1-  , iverbApply   = "hit"-  , iverbProject = "heave"-  , iweight  = 2000-  , itoThrow = -50  -- ensuring it hits with the tip costs speed-  }-wand = ItemKind-  { isymbol  = '/'-  , iname    = "wand"-  , ifreq    = [("useful", 10)]-  , iflavour = zipFancy brightCol-  , ieffect  = NoEffect-  , icount   = intToDeep 1-  , iverbApply   = "snap"-  , iverbProject = "zap"-  , iweight  = 300-  , itoThrow = 25  -- magic-  }-wand1 = wand-  { ieffect  = Dominate-  }-wand2 = wand-  { ifreq    = [("useful", 3)]-  , ieffect  = Heal (-25)-  }-fist = sword-  { isymbol  = '@'-  , iname    = "fist"-  , ifreq    = [("hth", 1), ("unarmed", 100)]-  , ieffect  = Hurt (rollDice 3 1) (intToDeep 0)-  , iverbApply   = "punch"-  , iverbProject = "ERROR, please report: iverbProject fist"-  }-foot = sword-  { isymbol  = '@'-  , iname    = "foot"-  , ifreq    = [("hth", 1), ("unarmed", 50)]-  , ieffect  = Hurt (rollDice 3 1) (intToDeep 0)-  , iverbApply   = "kick"-  , iverbProject = "ERROR, please report: iverbProject foot"-  }-tentacle = sword-  { isymbol  = 'S'-  , iname    = "tentacle"-  , ifreq    = [("hth", 1), ("monstrous", 100)]-  , ieffect  = Hurt (rollDice 3 1) (intToDeep 0)-  , iverbApply   = "hit"-  , iverbProject = "ERROR, please report: iverbProject tentacle"-  }
− LambdaHack/Content/ModeKind.hs 
@@ -1,259 +0,0 @@--- | 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 = "Purple"}-                  , playerHorror ]-  , playersEnemy = [ ("White", "Purple")-                   , ("White", "Horror Den")-                   , ("Purple", "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 = "Purple"-                                   , playerUI = True }-                  , playerHorror ]-  , playersEnemy = [ ("White", "Purple")-                   , ("White", "Horror Den")-                   , ("Purple", "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 
@@ -1,71 +0,0 @@--- | Rooms, halls and passages for LambdaHack.-module Content.PlaceKind ( cdefs ) where--import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Content.PlaceKind--cdefs :: ContentDef PlaceKind-cdefs = ContentDef-  { getSymbol = psymbol-  , getName = pname-  , getFreq = pfreq-  , validate = pvalidate-  , content =-      [rect, pillar, pillarC, pillar3, colonnade, colonnadeW]-  }-rect,        pillar, pillarC, pillar3, colonnade, colonnadeW :: PlaceKind--rect = PlaceKind  -- Valid for any nonempty area, hence low frequency.-  { psymbol  = 'r'-  , pname    = "room"-  , pfreq    = [("rogue", 100)]-  , pcover   = CStretch-  , pfence   = FNone-  , ptopLeft = [ "--"-               , "|."-               ]-  }-pillar = PlaceKind-  { psymbol  = 'p'-  , pname    = "pillar room"-  , pfreq    = [("rogue", 1000)]  -- larger rooms require support pillars-  , pcover   = CStretch-  , pfence   = FNone-  , ptopLeft = [ "-----"-               , "|...."-               , "|.O.."-               , "|...."-               , "|...."-               ]-  }-pillarC = pillar-  { ptopLeft = [ "-----"-               , "|O..."-               , "|...."-               , "|...."-               , "|...."-               ]-  }-pillar3 = pillar-  { ptopLeft = [ "-----"-               , "|&.O."-               , "|...."-               , "|O..."-               , "|...."-               ]-  }-colonnade = PlaceKind-  { psymbol  = 'c'-  , pname    = "colonnade"-  , pfreq    = [("rogue", 500)]-  , pcover   = CAlternate-  , pfence   = FFloor-  , ptopLeft = [ "O."-               , ".O"-               ]-  }-colonnadeW = colonnade-  { ptopLeft = [ "O."-               , ".."-               ]-  }
− LambdaHack/Content/RuleKind.hs 
@@ -1,82 +0,0 @@-{-# 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)--import Game.LambdaHack.Common.ContentDef-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind--cdefs :: ContentDef RuleKind-cdefs = ContentDef-  { getSymbol = rsymbol-  , getName = rname-  , getFreq = rfreq-  , validate = ruvalidate-  , content =-      [standard]-  }--standard :: RuleKind-standard = RuleKind-  { rsymbol        = 's'-  , rname          = "standard LambdaHack ruleset"-  , rfreq          = [("standard", 100)]-  -- Check whether one position is accessible from another.-  -- Precondition: the two positions are next to each other.-  -- Apart of checking the target tile, we forbid diagonal movement-  -- to and from doors.-  , raccessible    = \ lxsize spos src tpos tgt ->-      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.-  -- Warning: cabal does not detect that the config files are changed,-  -- 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 = $(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 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. 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: Show highlighted keybinding in inverse video or bright white on grey-  -- background. The spaces that pad keybindings are not highlighted.-  , rmainMenuArt = $(do-      qAddDependentFile "MainMenu.ascii"-      x <- qRunIO (readFile "MainMenu.ascii")-      lift x)-  }
− LambdaHack/Content/TileKind.hs 
@@ -1,307 +0,0 @@--- | Terrain tiles for LambdaHack.-module Content.TileKind ( cdefs ) where--import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.ContentDef-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Feature-import Game.LambdaHack.Content.TileKind--cdefs :: ContentDef TileKind-cdefs = ContentDef-  { getSymbol = tsymbol-  , getName = tname-  , getFreq = tfreq-  , validate = tvalidate-  , content =-      [wall, hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRedDark, floorBlueDark, floorGreenDark, floorBrownDark, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit]-  }-wall,        hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRedDark, floorBlueDark, floorGreenDark, floorBrownDark, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind--wall = TileKind-  { tsymbol  = ' '-  , tname    = "bedrock"-  , tfreq    = [("fillerWall", 1), ("litLegend", 100), ("darkLegend", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = []-  }-hardRock = TileKind-  { tsymbol  = ' '-  , tname    = "impenetrable bedrock"-  , tfreq    = [("outer fence", 1)]-  , tcolor   = BrBlack-  , tcolor2  = BrBlack-  , tfeature = [Impenetrable]-  }-pillar = TileKind-  { tsymbol  = 'O'-  , tname    = "rock"-  , tfreq    = [ ("cachable", 70)-               , ("litLegend", 100), ("darkLegend", 100)-               , ("noiseSet", 55), ("combatSet", 3) ]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = []-  }-pillarCache = TileKind-  { tsymbol  = '&'-  , tname    = "cache"-  , tfreq    = [ ("cachable", 30)-               , ("litLegend", 100), ("darkLegend", 100) ]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [Cause $ Effect.CreateItem 1, ChangeTo "cachable"]-  }-tree = TileKind-  { tsymbol  = 'O'-  , tname    = "tree"-  , tfreq    = [("combatSet", 8)]-  , tcolor   = BrGreen-  , tcolor2  = Green-  , tfeature = []-  }-wallV = TileKind-  { tsymbol  = '|'-  , tname    = "granite wall"-  , tfreq    = [("litLegend", 100), ("darkLegend", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [HideAs "suspect vertical wall"]-  }-wallSuspectV = TileKind-  { tsymbol  = '|'-  , tname    = "moldy wall"-  , tfreq    = [("suspect vertical wall", 1)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [ Suspect-               , RevealAs "vertical closed door"-               ]-  }-doorClosedV = TileKind-  { tsymbol  = '+'-  , tname    = "closed door"-  , tfreq    = [("vertical closed door", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ Exit-               , OpenTo "vertical open door"-               , HideAs "suspect vertical wall"-               ]-  }-doorOpenV = TileKind-  { tsymbol  = '-'-  , tname    = "open door"-  , tfreq    = [("vertical open door", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, Exit-               , CloseTo "vertical closed door"-               ]-  }-wallH = TileKind-  { tsymbol  = '-'-  , tname    = "granite wall"-  , tfreq    = [("litLegend", 100), ("darkLegend", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [HideAs "suspect horizontal wall"]-  }-wallSuspectH = TileKind-  { tsymbol  = '-'-  , tname    = "scratched wall"-  , tfreq    = [("suspect horizontal wall", 1)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [ Suspect-               , RevealAs "horizontal closed door"-               ]-  }-doorClosedH = TileKind-  { tsymbol  = '+'-  , tname    = "closed door"-  , tfreq    = [("horizontal closed door", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ Exit-               , OpenTo "horizontal open door"-               , HideAs "suspect horizontal wall"-               ]-  }-doorOpenH = TileKind-  { tsymbol  = '|'-  , tname    = "open door"-  , tfreq    = [("horizontal open door", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, Exit-               , CloseTo "horizontal closed door"-               ]-  }-stairsUpDark = TileKind-  { tsymbol  = '<'-  , tname    = "staircase up"-  , 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, Cause $ Effect.Ascend 1]-  }-stairsUpLit = stairsUpDark-  { tfreq    = [("litLegend", 100)]-  , tcolor   = BrWhite-  , 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)]-  , tcolor   = BrWhite-  , tcolor2  = BrBlack-  , tfeature = [Walkable, Clear, Exit, Cause $ Effect.Ascend (-1)]-  }-stairsDownLit = stairsDownDark-  { tfreq    = [("litLegend", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = Lit : tfeature stairsDownDark-  }-escapeUpDark = TileKind-  { tsymbol  = '<'-  , tname    = "exit trapdoor up"-  , tfreq    = [("darkLegend", 100)]-  , tcolor   = BrYellow-  , tcolor2  = BrYellow-  , tfeature = [Walkable, Clear, Exit, Cause Effect.Escape]-  }-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  = ' '-  , tname    = "unknown space"-  , tfreq    = [("unknown space", 1)]-  , tcolor   = defFG-  , tcolor2  = BrWhite-  , tfeature = []-  }-floorCorridorLit = TileKind-  { tsymbol  = '#'-  , tname    = "corridor"-  , tfreq    = [("floorCorridorLit", 1)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [Walkable, Clear, Lit]-  }-floorCorridorDark = floorCorridorLit-  { tfreq    = [("floorCorridorDark", 1)]--- Disabled, because dark corridors and yellow light does not fit LambdaHack.---  , tcolor   = BrYellow---  , tcolor2  = BrBlack-  , tfeature = [Walkable, Clear]-  }-floorArenaLit = floorCorridorLit-  { tsymbol  = '.'-  , tname    = "stone floor"-  , tfreq    = [ ("floorArenaLit", 1)-               , ("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100) ]-  }-floorArenaDark = floorCorridorDark-  { tsymbol  = '.'-  , tname    = "stone floor"-  , tfreq    = [("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100)]--- Disabled, because the yellow artificial light does not fit LambdaHack.---  , tcolor   = BrYellow--- Dark room interior, OTOH, is fine:-  , tcolor2  = BrBlack-  }-floorItemLit = floorArenaLit-  { tfreq    = []-  , tfeature = CanItem : tfeature floorArenaLit-  }-floorItemDark = floorArenaDark-  { tfreq    = []-  , tfeature = CanItem : tfeature floorArenaDark-  }-floorActorItemLit = floorItemLit-  { tfreq    = [("litLegend", 100), ("emptySet", 1)]-  , tfeature = CanActor : tfeature floorItemLit-  }-floorActorItemDark = floorItemDark-  { tfreq    = [("darkLegend", 100), ("emptySet", 1)]-  , tfeature = CanActor : tfeature floorItemDark-  }-floorRedDark = floorArenaDark-  { tname    = "brick pavement"-  , tfreq    = [("pathDark", 30)]-  , tcolor   = BrRed-  , tcolor2  = Red-  , tfeature = Path : tfeature floorArenaDark-  }-floorRedLit  = floorRedDark-  { tfreq    = [("pathLit", 30)]-  , tfeature = Lit : tfeature floorRedDark-  }-floorBlueDark = floorRedDark-  { tname    = "granite cobblestones"-  , tfreq    = [("pathDark", 100)]-  , tcolor   = BrBlue-  , tcolor2  = Blue-  }-floorBlueLit = floorBlueDark-  { tfreq    = [("pathLit", 100)]-  , tfeature = Lit : tfeature floorBlueDark-  }-floorGreenDark = floorRedDark-  { tname    = "mossy stone path"-  , tfreq    = [("pathDark", 100)]-  , tcolor   = BrGreen-  , tcolor2  = Green-  }-floorGreenLit = floorGreenDark-  { tfreq    = [("pathLit", 100)]-  , tfeature = Lit : tfeature floorGreenDark-  }-floorBrownDark = floorRedDark-  { tname    = "rotting mahogany deck"-  , tfreq    = [("pathDark", 10)]-  , tcolor   = BrMagenta-  , tcolor2  = Magenta-  }-floorBrownLit = floorBrownDark-  { tfreq    = [("pathLit", 10)]-  , tfeature = Lit : tfeature floorBrownDark-  }
− LambdaHack/Main.hs 
@@ -1,50 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | 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--import qualified Content.ActorKind-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.TileKind-import Game.LambdaHack.Client-import Game.LambdaHack.Client.Action.ActionType-import Game.LambdaHack.Common.Action (MonadAtomic (..))-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.AtomicSem-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Server-import Game.LambdaHack.Server.Action.ActionType-import Game.LambdaHack.Server.AtomicSemSer---- | The game-state semantics of atomic game commands--- as computed on the server.-instance MonadAtomic ActionSer where-  execAtomic = atomicSendSem---- | The game-state semantics of atomic game commands--- as computed on clients. Special effects (@SfxAtomic@) don't modify state.-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-        { coactor   = Kind.createOps Content.ActorKind.cdefs-        , cocave    = Kind.createOps Content.CaveKind.cdefs-        , cofaction = 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-        , cotile    = Kind.createOps Content.TileKind.cdefs-        }-  in mainSer copsSlow executorSer $ exeFrontend executorCli executorCli
− MainMenu.ascii 
@@ -1,26 +0,0 @@------------------------------------------------------------------------------------|                                                                                |-|                      >> LambdaHack <<                                          |-|                                                                                |-|                                                                                |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                                                                                |-|                                                                                |-|                        Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) |-----------------------------------------------------------------------------------
Makefile view
@@ -12,134 +12,228 @@ 	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer  xcpeekCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign  xcpeekSkirmish:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish  xcfrontendCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCampaign --difficulty 1 +xcfrontendSkirmish:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testSkirmish++xcfrontendBattle:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testBattle --difficulty 1++xcfrontendPvP:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testPvP --fovMode Shadow+ xcfrontendCoop:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCoop --difficulty 1 --fovMode Permissive  xcfrontendDefense:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testDefense --difficulty 9 +xcbenchCampaign:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42 -xctest-travis: xctest-short xctest-medium+xcbenchBattle:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42 +xcbenchFrontendCampaign:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42++xcbenchFrontendBattle:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42++xcbenchNo: xcbenchCampaign xcbenchBattle++xcbench: xcbenchCampaign xcbenchFrontendCampaign xcbenchBattle xcbenchFrontendBattle++xctest-travis: xctest-short xctest-medium xcbenchNo++xctest-travis-long: xctest-short xctest-long xcbenchNo+ xctest: xctest-short xctest-medium xctest-long  xctest-short: xctest-short-new xctest-short-load -xctest-medium: xctestCampaign-medium xctestCoop-medium xctestDefense-medium+xctest-medium: xctestCampaign-medium xctestSkirmish-medium xctestBattle-medium xctestPvP-medium xctestCoop-medium xctestDefense-medium  xctest-long: xctestCampaign-long xctestCoop-long xctestDefense-long  xctestCampaign-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 1000 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log  xctestCampaign-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log +xctestSkirmish-long:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log++xctestSkirmish-medium:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log++xctestBattle-long:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log++xctestBattle-medium:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log++xctestPvP-long:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log++xctestPvP-medium:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log+ xctestCoop-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Permissive --savePrefix test --gameMode testCoop --frontendStd --stopAfter 1000 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log  xctestCoop-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Shadow --savePrefix test --gameMode testCoop --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log  xctestDefense-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noAnim --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 1000 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log  xctestDefense-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log  xctest-short-new:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log  xctest-short-load:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log   play: 	dist/build/LambdaHack/LambdaHack --dbgMsgSer  peekCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign  peekSkirmish:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish  frontendCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCampaign --difficulty 1 +frontendSkirmish:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testSkirmish++frontendBattle:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testBattle --difficulty 1++frontendPvP:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testPvP --fovMode Shadow+ frontendCoop:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCoop --difficulty 1 --fovMode Permissive  frontendDefense:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testDefense --difficulty 9 +benchCampaign:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42 -test-travis: test-short test-medium+benchBattle:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42 +benchFrontendCampaign:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42++benchFrontendBattle:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42++benchNo: benchCampaign benchBattle++bench: benchCampaign benchFrontendCampaign benchBattle benchFrontendBattle+++test-travis: test-short test-medium benchNo++test-travis-long: test-short test-long benchNo+ test: test-short test-medium test-long  test-short: test-short-new test-short-load -test-medium: testCampaign-medium testCoop-medium testDefense-medium+test-medium: testCampaign-medium testSkirmish-medium testBattle-medium testPvP-medium testCoop-medium testDefense-medium  test-long: testCampaign-long testCoop-long testDefense-long  testCampaign-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 1000 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log  testCampaign-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log +testSkirmish-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log++testSkirmish-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log++testBattle-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log++testBattle-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log++testPvP-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log++testPvP-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log+ testCoop-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Permissive --savePrefix test --gameMode testCoop --frontendStd --stopAfter 1000 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log  testCoop-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Shadow --savePrefix test --gameMode testCoop --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log  testDefense-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noAnim --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 1000 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log  testDefense-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log  test-short-new:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log  test-short-load:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log+	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log  + # The rest of the makefile is unmaintained at the moment.  default : dist/setup-config@@ -161,4 +255,4 @@ 	runghc Setup clean  ghci :-	ghci -XCPP -idist/build/autogen:Game/LambdaHack+	ghci -XCPP -idist/build/autogen:.
− PLAYING.md 
@@ -1,171 +0,0 @@-Playing LambdaHack-==================--LambdaHack is a small dungeon crawler illustrating the roguelike game engine-library also called LambdaHack. Playing the game involves walking around-the dungeon, alone or in a party of fearless adventurers, setting up ambushes,-hiding in shadow, covering tracks, breaking through to deeper caves,-bumping into monsters, doors and walls, gathering magical treasure-and making creative use of it. The bloodthirsty monsters do the same,-intelligence allowing, while tirelessly chasing the elusive heroes-by smell and sight.--Once the few basic command keys and on-screen symbols are learned,-mastery and enjoyment of the game is the matter of tactical skill-and literary imagination. To be honest, a lot of imagination is required-for this simple game, but it's playable and winnable.-The game also features multiplayer cooperative and competitive modes,-though only a shared-screen interface is provided at this time.---Dungeon----------The heroes are marked on the map with symbols '@' and '1' through '9'.-Their goal is to explore the dungeon, battle the horrors within,-gather as much gold and gems as possible, and escape to tell the tale.-The dungeon of the campaign mode game consists of 10 levels and each level-consists of large number of tiles. The basic tiles are as follows.--               dungeon terrain type               on-screen symbol-               floor                              .-               corridor                           #-               wall (horizontal and vertical)     - and |-               rock or tree                       O-               cache                              &-               stairs up                          <-               stairs down                        >-               open door                          | and --               closed door                        +-               bedrock                            blank--The game world is persistent, i.e., every time the player visits a level-during a single game, the level layout is the same.---Keys-------You move throughout the level using the numerical keypad or-the vi text editor keys (also known as "Rogue-like keys").--               7 8 9     y k u-                \|/       \|/-               4-5-6     h-.-l-                /|\       /|\-               1 2 3     b j n--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-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.--               key       command-               <         ascend a level*-               >         descend a level*-               ?         display help-               I         display inventory-               c         close a door*-               d         drop an object*-               g         get an object*-               o         open a door*-               q         quaff a potion*-               r         read a scroll*-               t         throw a dart*-               z         zap a wand*--To make a ranged attack, you need to set your target first,-using targeting mode ('*' and '/' keys). The target, for the few-commands that require any, is indicated by the targeting cursor.-To avoid confusion, commands that take time are blocked when targeting-at a remote level (when the cursor is displayed on a different level-than the selected hero). The targeting commands and all the less used-commands are listed below. None of them takes hero time.--               key       command-               ESC       cancel action or bring up the Main Menu-               RET       accept choice-               TAB       cycle among heroes on the level-               SHIFT-TAB cycle among heroes in the dungeon-               *         target monster-               +         swerve targeting line-               -         unswerve targeting line-               /         target position-               P         display previous messages-               S         mark smell-               T         mark suspect terrain-               V         mark visible area-               [         target next shallower level-               ]         target next deeper level-               {         target 10 levels shallower-               }         target 10 levels deeper-               0--9      select a hero anywhere in the dungeon--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-x    save and exit-               CTRL-r    new campaign game-               CTRL-k    new skirmish game-               CTRL-p    new PvP game-               CTRL-o    new Coop game-               CTRL-e    new defense game--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-----------Heroes are not alone in the dungeon. Monsters roam the dark caves-and crawl from damp holes day and night. While heroes pay attention-to all other party members and take care to move one at a time,-monsters don't care about each other and all move at once,-sometimes brutally colliding by accident.--When the hero bumps into a monster or a monster attacks the hero,-melee combat occurs. The best weapon carried by each opponent-is taken into account for calculating bonus damage. The total damage-the current hero can potentially inflict is displayed at the bottom-of the screen. The total damage potential of a monster may change-as it finds and picks up new weapons. Heroes and monsters running into-one another (with the Shift key) do not inflict damage, but change places.-This gives the opponent a free blow, but can improve the tactical situation-or aid escape.--Throwing weapons at targets wounds them, consuming the weapon in the process.-Target a monster with the '*' key from the top keyboard row or from keypad.-You may throw any object in your possession (press '?' to choose-an object and press it again for a non-standard choice) or on the floor-(press '-'). Only objects of a few kinds inflict any damage.-Whenever the monster's or hero's hit points reach zero, the combatant dies.-When the last hero dies, the game ends.---On Winning and Dying-----------------------You win the game if you escape the dungeon alive (or eliminate-all opposition, in some game modes). Your score is-the sum of all gold you've plundered plus 100 gold pieces for each gem.-Only the loot in possession of the party members on the current level-counts (the rest of the party is considered MIA).--If all heroes die, your score is halved and only the treasure carried-by the last standing hero counts. You are free to start again-from a different entrance to the dungeon, but all your previous wealth-is gone and fresh, undaunted enemies bar your way.
README.md view
@@ -1,4 +1,4 @@-LambdaHack [![Build Status](https://secure.travis-ci.org/kosmikus/LambdaHack.png)](http://travis-ci.org/kosmikus/LambdaHack)+LambdaHack [![Build Status](https://secure.travis-ci.org/kosmikus/LambdaHack.png)](http://travis-ci.org/kosmikus/LambdaHack)[![Build Status](https://drone.io/github.com/kosmikus/LambdaHack/status.png)](https://drone.io/github.com/kosmikus/LambdaHack/latest) ==========  This is an alpha release of LambdaHack, a [Haskell] [1] game engine@@ -13,11 +13,10 @@ in the strict and type-safe separation of code and content and of clients (human and AI-controlled) and server. Long-term goals for LambdaHack include support for multiplayer tactical squad combat, in-game content creation,-auto-balancing and persistent content modification based-on player behaviour.+auto-balancing and persistent content modification based on player behaviour.  The engine comes with a sample code for a little dungeon crawler,-called LambdaHack and described in PLAYING.md. The engine and the example+called LambdaHack and described in `PLAYING.md`. The engine and the example game are bundled together in a single [Hackage] [3] package. You are welcome to create your own games by modifying the sample game and the engine code, but please consider eventually splitting your changes@@ -32,9 +31,11 @@ Compilation and installation ---------------------------- -The library is best compiled and installed via Cabal, which also takes care-of all dependencies. The latest official version of the library-can be downloaded automatically by Cabal from [Hackage] [3] as follows+The library is best compiled and installed via Cabal (already a part+of your OS distribution, or available within [The Haskell Platform] [7]),+which also takes care of all the dependencies. The latest official+version of the library can be downloaded automatically by Cabal+from [Hackage] [3] as follows      cabal install LambdaHack @@ -53,33 +54,31 @@ Compatibility notes ------------------- -The current code was tested with GHC 7.6.3, but should also work with-other GHC versions (see file .travis.yml.7.4.2 for GHC 7.4.2 commands).+The current code was tested with GHC 7.6 and 7.8, but should also work with+other GHC versions (see file `.travis.yml.7.4.2` for GHC 7.4 commands). -If you are using the curses or vty frontends,-numerical keypad may not work correctly depending on the versions-of curses, terminfo and terminal emulators.-Selecting heroes via number keys or SHIFT-keypad keys is disabled-with curses, because CTRL-keypad for running does not work there,-so the numbers produced by the keypad have to be used. With vty on xterm,-CTRL-direction keys seem to work OK, but on rxvt they do not.-Vi keys (ykuhlbjn) should work everywhere regardless. Gtk works fine, too.+If you are using the terminal frontends, numerical keypad may not work+correctly depending on versions of the libraries, terminfo and terminal+emulators. The curses frontend is not fully supported due to the limitations+of the curses library. With the vty frontend run in an xterm,+CTRL-keypad keys for running seem to work OK, but on rxvt they do not.+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+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+in `make test`. Of these, travis runs one of the sets prefixed+`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,+and the server. Some options in the config file may turn out useful too, though they mostly overlap with commandline options (and will be totally merged at some point). @@ -101,7 +100,7 @@ -------------------  For more information, visit the [wiki] [4]-and see the files PLAYING.md, CREDITS and LICENSE.+and see `GameDefinition/PLAYING.md`, `CREDITS` and `LICENSE`.  Have fun! @@ -113,3 +112,4 @@ [4]: https://github.com/kosmikus/LambdaHack/wiki [5]: http://github.com/kosmikus/LambdaHack [6]: http://hackage.haskell.org/package/Allure+[7]: http://www.haskell.org/platform
changelog view
@@ -1,44 +1,55 @@-0.2.0--	* the LambdaHack engine becomes a Haskell library--	* the LambdaHack game depends on the engine library--0.2.1--	* missiles flying for three turns (by an old kosmikus' idea)--	* visual feedback for targeting--	* animations of combat and individual monster moves--0.2.6--	* the Main Menu+v0.2.12 -	* improved and configurable mode of squad combat+        * improve and simplify dungeon generation+        * simplify running and permit multi-actor runs+        * let items explode and generate shrapnel projectiles+        * add game difficulty setting (initial HP scaling right now)+        * allow recording, playing back and looping commands+        * implement pathfinding via per-actor BFS over the whole level+        * extend setting targets for actors in UI tremendously+        * implement autoexplore, go-to-target, etc., as macros+        * let AI use pathfinding, switch leaders, pick levels to swarm to+        * force level/leader changes on spawners (even when played by humans)+        * extend and redesign UI bottom status lines+        * get rid of CPS style monads, aborts and WriterT+        * benchmark and optimize the code, in particular using Data.Vector+        * split off and use the external library assert-failure+        * simplify config files and limit the number of external dependencies -0.2.6.5+v0.2.10 -	* this is a minor release, primarily intended to fix the broken haddock documentation on Hackage+        * screensaver game modes (AI vs AI)+        * improved AI (can now climbs stairs, etc.)+        * multiple, multi-floor staircases+        * multiple savefiles+        * configurable framerate and combat animations -	* changes since 0.2.6 are mostly unrelated to gameplay: strictly typed config files split into UI and rules; a switch from Text to String throughout the codebase; use of the external library miniutter for English sentence generation+v0.2.8 -0.2.8+        * cooperative and competitive multiplayer (shared-screen only in this version)+        * overhauled searching+        * rewritten engine code 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 -	* cooperative and competitive multiplayer (shared-screen only in this version)-	* overhauled searching+v0.2.6.5 -	* rewritten engine code 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+        * this is a minor release, primarily intended to fix the broken haddock documentation on Hackage+        * changes since 0.2.6 are mostly unrelated to gameplay:+          - strictly typed config files split into UI and rules+          - a switch from Text to String throughout the codebase+          - use of the external library miniutter for English sentence generation -0.2.10+v0.2.6 -	* screensaver game modes (AI vs AI)+        * the Main Menu+        * improved and configurable mode of squad combat -	* improved AI (can now climbs stairs, etc.)+v0.2.1 -	* multiple, multi-floor staircases+        * missiles flying for three turns (by an old kosmikus' idea)+        * visual feedback for targeting+        * animations of combat and individual monster moves -	* multiple savefiles+v0.2.0 -	* configurable framerate and combat animations+        * the LambdaHack engine becomes a Haskell library+        * the LambdaHack game depends on the engine library
− config.rules.default 
@@ -1,28 +0,0 @@-; ; This is a commented out copy of the default game rules config file-; ; that is embedded in the binary.-; ; A user config file can overrides these options. The game looks for it at-; ; ~/.LambdaHack/config.rules.ini (or a similar path, depending on the OS).-; ; Warning: options are case-sensitive and only ';' for comments is permitted.--; [engine]-; ;dungeonRandomGenerator: 42-; firstDeathEnds: False-; fovMode: Digital 12-; ;fovMode: Permissive-; ;fovMode: Shadow-; ;startingRandomGenerator: 42-; saveBkpClips: 500--; [file]-; ; Names (or prefixes) of various game files.-; ; They reside in ~/.LambdaHack or similar.-; savePrefix: save-; scoresFile: scores--; [heroName]-; HeroName_0: Haskell Alvin-; HeroName_1: Alonzo Barkley-; HeroName_2: Ines Galenti-; HeroName_3: Ernst Abraham-; HeroName_4: Samuel Saunders-; HeroName_5: Roger Robin
− config.ui.default 
@@ -1,63 +0,0 @@-; ; This is a commented out copy of the default UI settings config file-; ; that is embedded in the binary.-; ; A user config file can overrides these options. The game looks for it at-; ; ~/.LambdaHack/config.ui.ini (or a similar path, depending on the OS).-; ; Warning: options are case-sensitive and only ';' for comments is permitted.--; [commands]-; ; All commands are defined here, except movement, hero selection and debug.-; ;-; KP_Begin: Wait-; g: Pickup-; d: Drop-; t: Project [ApplyItem {verb = "throw", object = "missile", symbol = '|'}]-; 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: 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"-; CTRL-p: GameRestart "PvP"-; CTRL-o: GameRestart "Coop"-; CTRL-e: GameRestart "defense"-; CTRL-x: GameExit-; CTRL-s: GameSave-; Tab: MemberCycle-; ISO_Left_Tab: MemberBack-; I: Inventory-; slash: TgtFloor-; asterisk: TgtEnemy-; bracketleft:  TgtAscend 1-; bracketright: TgtAscend (-1)-; braceleft:    TgtAscend 10-; braceright:   TgtAscend (-10)-; plus: EpsIncr True-; minus: EpsIncr False-; Escape: Cancel-; Return: Accept-; space: Clear-; P: History-; V: MarkVision-; S: MarkSmell-; 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-; period: KP_Begin--; [ui]-; font: Terminus,Monospace normal normal normal normal 12-; historyMax: 5000-; maxFps: 15-; noAnim: False
− scores

binary file changed (299 → absent bytes)