LambdaHack 0.2.6.5 → 0.2.8

raw patch · 168 files changed

+15119/−10702 lines, 168 filesdep +deepseqdep +enummapsetdep +ghc-primdep ~binarydep ~containersdep ~miniutterPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: deepseq, enummapset, ghc-prim, hashable, keys, stm, transformers, unordered-containers

Dependency ranges changed: binary, containers, miniutter

API changes (from Hackage documentation)

Files

• Game/LambdaHack/Ability.hs +0/−20
• Game/LambdaHack/Action.hs +0/−460
• Game/LambdaHack/Action/ActionLift.hs +0/−214
• Game/LambdaHack/Action/ConfigIO.hs +0/−190
• Game/LambdaHack/Action/Frontend.hs +0/−33
• Game/LambdaHack/Action/Frontend/Chosen.hs +0/−21
• Game/LambdaHack/Action/Frontend/Curses.hs +0/−158
• Game/LambdaHack/Action/Frontend/Gtk.hs +0/−463
• Game/LambdaHack/Action/Frontend/Std.hs +0/−107
• Game/LambdaHack/Action/Frontend/Vty.hs +0/−128
• Game/LambdaHack/Action/HighScore.hs +0/−152
• Game/LambdaHack/Action/Save.hs +0/−143
• Game/LambdaHack/Actions.hs +0/−644
• Game/LambdaHack/Actor.hs +0/−198
• Game/LambdaHack/ActorState.hs +0/−307
• Game/LambdaHack/Animation.hs +0/−128
• Game/LambdaHack/Area.hs +0/−62
• Game/LambdaHack/AreaRnd.hs +0/−145
• Game/LambdaHack/Binding.hs +0/−87
• Game/LambdaHack/BindingAction.hs +0/−73
• Game/LambdaHack/CDefs.hs +0/−23
• Game/LambdaHack/Cave.hs +0/−206
• Game/LambdaHack/Client.hs +117/−0
• Game/LambdaHack/Client/Action.hs +428/−0
• Game/LambdaHack/Client/Action/ActionClass.hs +75/−0
• Game/LambdaHack/Client/Action/ActionType.hs +103/−0
• Game/LambdaHack/Client/Action/ConfigIO.hs +122/−0
• Game/LambdaHack/Client/Action/Save.hs +95/−0
• Game/LambdaHack/Client/AtomicSemCli.hs +661/−0
• Game/LambdaHack/Client/Binding.hs +119/−0
• Game/LambdaHack/Client/ClientSem.hs +208/−0
• Game/LambdaHack/Client/Config.hs +45/−0
• Game/LambdaHack/Client/Draw.hs +198/−0
• Game/LambdaHack/Client/HumanCmd.hs +154/−0
• Game/LambdaHack/Client/HumanGlobal.hs +432/−0
• Game/LambdaHack/Client/HumanLocal.hs +615/−0
• Game/LambdaHack/Client/HumanSem.hs +161/−0
• Game/LambdaHack/Client/LoopAction.hs +90/−0
• Game/LambdaHack/Client/RunAction.hs +209/−0
• Game/LambdaHack/Client/State.hs +206/−0
• Game/LambdaHack/Client/Strategy.hs +84/−0
• Game/LambdaHack/Client/StrategyAction.hs +405/−0
• Game/LambdaHack/Color.hs +0/−126
• Game/LambdaHack/Command.hs +0/−108
• Game/LambdaHack/CommandAction.hs +0/−73
• Game/LambdaHack/Common/Ability.hs +25/−0
• Game/LambdaHack/Common/Action.hs +49/−0
• Game/LambdaHack/Common/Actor.hs +274/−0
• Game/LambdaHack/Common/ActorState.hs +180/−0
• Game/LambdaHack/Common/Animation.hs +219/−0
• Game/LambdaHack/Common/Area.hs +62/−0
• Game/LambdaHack/Common/AtomicCmd.hs +185/−0
• Game/LambdaHack/Common/AtomicPos.hs +247/−0
• Game/LambdaHack/Common/AtomicSem.hs +409/−0
• Game/LambdaHack/Common/ClientCmd.hs +79/−0
• Game/LambdaHack/Common/Color.hs +138/−0
• Game/LambdaHack/Common/ContentDef.hs +23/−0
• Game/LambdaHack/Common/Effect.hs +120/−0
• Game/LambdaHack/Common/Faction.hs +168/−0
• Game/LambdaHack/Common/Feature.hs +39/−0
• Game/LambdaHack/Common/Flavour.hs +99/−0
• Game/LambdaHack/Common/HighScore.hs +159/−0
• Game/LambdaHack/Common/Item.hs +209/−0
• Game/LambdaHack/Common/Key.hs +232/−0
• Game/LambdaHack/Common/Kind.hs +185/−0
• Game/LambdaHack/Common/Level.hs +228/−0
• Game/LambdaHack/Common/Misc.hs +94/−0
• Game/LambdaHack/Common/Msg.hs +219/−0
• Game/LambdaHack/Common/Perception.hs +107/−0
• Game/LambdaHack/Common/Point.hs +113/−0
• Game/LambdaHack/Common/PointXY.hs +73/−0
• Game/LambdaHack/Common/Random.hs +165/−0
• Game/LambdaHack/Common/ServerCmd.hs +50/−0
• Game/LambdaHack/Common/State.hs +204/−0
• Game/LambdaHack/Common/Tile.hs +104/−0
• Game/LambdaHack/Common/Time.hs +160/−0
• Game/LambdaHack/Common/Vector.hs +161/−0
• Game/LambdaHack/Common/VectorXY.hs +42/−0
• Game/LambdaHack/Config.hs +0/−123
• Game/LambdaHack/Content/ActorKind.hs +7/−6
• Game/LambdaHack/Content/CaveKind.hs +24/−25
• Game/LambdaHack/Content/FactionKind.hs +6/−8
• Game/LambdaHack/Content/ItemKind.hs +12/−21
• Game/LambdaHack/Content/PlaceKind.hs +1/−1
• Game/LambdaHack/Content/RuleKind.hs +6/−6
• Game/LambdaHack/Content/StrategyKind.hs +2/−2
• Game/LambdaHack/Content/TileKind.hs +10/−6
• Game/LambdaHack/Draw.hs +0/−183
• Game/LambdaHack/Dungeon.hs +0/−85
• Game/LambdaHack/DungeonState.hs +0/−182
• Game/LambdaHack/Effect.hs +0/−61
• Game/LambdaHack/EffectAction.hs +0/−625
• Game/LambdaHack/FOV.hs +0/−68
• Game/LambdaHack/FOV/Common.hs +0/−67
• Game/LambdaHack/FOV/Digital.hs +0/−144
• Game/LambdaHack/FOV/Permissive.hs +0/−154
• Game/LambdaHack/FOV/Shadow.hs +0/−111
• Game/LambdaHack/Feature.hs +0/−32
• Game/LambdaHack/Flavour.hs +0/−95
• Game/LambdaHack/Frontend.hs +207/−0
• Game/LambdaHack/Frontend/Chosen.hs +21/−0
• Game/LambdaHack/Frontend/Curses.hs +158/−0
• Game/LambdaHack/Frontend/Gtk.hs +417/−0
• Game/LambdaHack/Frontend/Std.hs +107/−0
• Game/LambdaHack/Frontend/Vty.hs +129/−0
• Game/LambdaHack/Item.hs +0/−254
• Game/LambdaHack/ItemAction.hs +0/−525
• Game/LambdaHack/Key.hs +0/−209
• Game/LambdaHack/Kind.hs +0/−177
• Game/LambdaHack/Level.hs +0/−202
• Game/LambdaHack/Misc.hs +0/−25
• Game/LambdaHack/Msg.hs +0/−185
• Game/LambdaHack/Perception.hs +0/−194
• Game/LambdaHack/Place.hs +0/−184
• Game/LambdaHack/Point.hs +0/−102
• Game/LambdaHack/PointXY.hs +0/−60
• Game/LambdaHack/Random.hs +0/−143
• Game/LambdaHack/Running.hs +0/−194
• Game/LambdaHack/Server.hs +100/−0
• Game/LambdaHack/Server/Action.hs +382/−0
• Game/LambdaHack/Server/Action/ActionClass.hs +23/−0
• Game/LambdaHack/Server/Action/ActionType.hs +63/−0
• Game/LambdaHack/Server/Action/ConfigIO.hs +169/−0
• Game/LambdaHack/Server/Action/Save.hs +94/−0
• Game/LambdaHack/Server/AtomicSemSer.hs +180/−0
• Game/LambdaHack/Server/Config.hs +130/−0
• Game/LambdaHack/Server/DungeonGen.hs +135/−0
• Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +150/−0
• Game/LambdaHack/Server/DungeonGen/Cave.hs +150/−0
• Game/LambdaHack/Server/DungeonGen/Place.hs +183/−0
• Game/LambdaHack/Server/EffectSem.hs +462/−0
• Game/LambdaHack/Server/Fov.hs +179/−0
• Game/LambdaHack/Server/Fov/Common.hs +67/−0
• Game/LambdaHack/Server/Fov/Digital.hs +142/−0
• Game/LambdaHack/Server/Fov/Permissive.hs +152/−0
• Game/LambdaHack/Server/Fov/Shadow.hs +111/−0
• Game/LambdaHack/Server/LoopAction.hs +406/−0
• Game/LambdaHack/Server/ServerSem.hs +445/−0
• Game/LambdaHack/Server/StartAction.hs +248/−0
• Game/LambdaHack/Server/State.hs +132/−0
• Game/LambdaHack/State.hs +0/−322
• Game/LambdaHack/Strategy.hs +0/−84
• Game/LambdaHack/StrategyAction.hs +0/−390
• Game/LambdaHack/Tile.hs +0/−96
• Game/LambdaHack/Time.hs +0/−143
• Game/LambdaHack/Turn.hs +0/−289
• Game/LambdaHack/Utils/Assert.hs +9/−23
• Game/LambdaHack/Utils/File.hs +24/−3
• Game/LambdaHack/Utils/Frequency.hs +7/−6
• Game/LambdaHack/Utils/LQueue.hs +32/−8
• Game/LambdaHack/Vector.hs +0/−163
• Game/LambdaHack/VectorXY.hs +0/−39
• LambdaHack.cabal +139/−101
• LambdaHack/Content/ActorKind.hs +14/−14
• LambdaHack/Content/CaveKind.hs +29/−13
• LambdaHack/Content/FactionKind.hs +25/−20
• LambdaHack/Content/ItemKind.hs +40/−50
• LambdaHack/Content/PlaceKind.hs +6/−6
• LambdaHack/Content/RuleKind.hs +15/−16
• LambdaHack/Content/StrategyKind.hs +6/−6
• LambdaHack/Content/TileKind.hs +67/−29
• LambdaHack/Main.hs +19/−9
• PLAYING.md +52/−50
• README.md +14/−25
• config.rules.bot +0/−9
• config.rules.default +33/−15
• config.ui.default +30/−45
• scores binary

@@ -1,20 +0,0 @@--- | AI strategy abilities.-module Game.LambdaHack.Ability-  ( Ability(..)-  ) where---- | All possible AI actor abilities. AI chooses among these when considering--- the next action to perform. The ability descriptions refer to the target--- that any actor picks each turn, depending on the actor's characteristics--- and his environment.-data Ability =-    Track   -- ^ move along a set path, if any, meleeing any opponents-  | Heal    -- ^ heal if almost dead-  | Flee    -- ^ flee if almost dead-  | Melee   -- ^ melee target-  | Pickup  -- ^ gather items, if no foes visible-  | Ranged  -- ^ attack the visible target opponent at range, some of the time-  | Tools   -- ^ use items, if target opponent visible, some of the time-  | Chase   -- ^ chase the target, ignoring any actors on the way-  | Wander  -- ^ wander around, meleeing any opponents on the way-  deriving (Show, Eq, Ord, Enum, Bounded)

@@ -1,460 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Game action monad and basic building blocks for player and monster--- actions. Uses @liftIO@ of the @Action@ monad, but does not export it.--- Has no direct access to the Action monad implementation.-module Game.LambdaHack.Action-  ( -- * Actions and accessors-    Action, getPerception, getCOps, getBinding, getConfigUI-    -- * Actions returning frames-  , ActionFrame, returnNoFrame, returnFrame, whenFrame, inFrame, tryWithFrame-    -- * Various ways to abort action-  , abort, abortWith, abortIfWith, neverMind-    -- * Abort exception handlers-  , tryWith, tryRepeatedlyWith, tryIgnore-    -- * Diary and report-  , getDiary, msgAdd, recordHistory-    -- * Key input-  , getKeyCommand, getKeyFrameCommand, getOverConfirm-    -- * Display each frame and confirm-  , displayMore, displayYesNo, displayOverAbort-    -- * Assorted frame operations-  , displayOverlays, displayChoiceUI, displayFramePush, drawPrompt-    -- * Clip init operations-  , startClip, remember, rememberList-    -- * Assorted primitives-  , saveGameBkp, dumpCfg, endOrLoop, frontendName, startFrontend-  , debug-  ) where--import Control.Monad-import Control.Monad.State hiding (State, state, liftIO)-import qualified Data.IntMap as IM-import qualified Data.IntSet as IS-import qualified Data.Map as M-import System.Time-import Data.Maybe-import Control.Concurrent-import Control.Exception (finally)-import Data.Text (Text)-import qualified Data.Text as T--- import System.IO (hPutStrLn, stderr) -- just for debugging--import Game.LambdaHack.Action.ActionLift-import Game.LambdaHack.Perception-import Game.LambdaHack.Action.Frontend-import Game.LambdaHack.Draw-import Game.LambdaHack.Msg-import Game.LambdaHack.State-import Game.LambdaHack.Level-import Game.LambdaHack.Actor-import Game.LambdaHack.ActorState-import qualified Game.LambdaHack.Action.Save as Save-import qualified Game.LambdaHack.Kind as Kind-import qualified Game.LambdaHack.Key as K-import Game.LambdaHack.Binding-import Game.LambdaHack.Action.HighScore (register)-import Game.LambdaHack.Config-import qualified Game.LambdaHack.Action.ConfigIO as ConfigIO-import Game.LambdaHack.Animation (SingleFrame(..))-import Game.LambdaHack.Point-import qualified Game.LambdaHack.DungeonState as DungeonState-import Game.LambdaHack.Item-import Game.LambdaHack.Content.RuleKind-import qualified Game.LambdaHack.Tile as Tile---- | Set the current exception handler. Apart of executing it,--- draw and pass along a frame with the abort message, if any.-tryWithFrame :: Action a -> ActionFrame a -> ActionFrame a-tryWithFrame exc h =-  let msgToFrames ""  = returnNoFrame ()-      msgToFrames msg = do-        msgReset ""-        fr <- drawPrompt ColorFull msg-        returnFrame fr-      excMsg msg = do-        ((), frames) <- msgToFrames msg-        a <- exc-        return (a, frames)-  in tryWith excMsg h---- | Store current report in the history and reset report.-recordHistory :: Action ()-recordHistory = do-  Diary{sreport, shistory} <- getDiary-  unless (nullReport sreport) $ do-    ConfigUI{configHistoryMax} <- getConfigUI-    msgReset ""-    historyReset $ takeHistory configHistoryMax $ addReport sreport shistory---- | Wait for a player command.-getKeyCommand :: Maybe Bool -> Action (K.Key, K.Modifier)-getKeyCommand doPush = do-  fs <- getFrontendSession-  keyb <- getBinding-  (nc, modifier) <- liftIO $ nextEvent fs doPush-  return $ case modifier of-    K.NoModifier -> (fromMaybe nc $ M.lookup nc $ kmacro keyb, modifier)-    _ -> (nc, modifier)---- | Display frame and wait for a player command.-getKeyFrameCommand :: SingleFrame -> Action (K.Key, K.Modifier)-getKeyFrameCommand frame = do-  fs <- getFrontendSession-  keyb <- getBinding-  (nc, modifier) <- liftIO $ promptGetKey fs [] frame-  return $ case modifier of-    K.NoModifier -> (fromMaybe nc $ M.lookup nc $ kmacro keyb, modifier)-    _ -> (nc, modifier)---- | Ignore unexpected kestrokes until a SPACE or ESC is pressed.-getConfirm :: SingleFrame -> Action Bool-getConfirm frame = do-  fs <- getFrontendSession-  let keys = [ (K.Space, K.NoModifier), (K.Esc, K.NoModifier)]-  (k, _) <- liftIO $ promptGetKey fs keys frame-  case k of-    K.Space -> return True-    _       -> return False---- | A series of confirmations for all overlays.-getOverConfirm :: [SingleFrame] -> Action Bool-getOverConfirm []     = return True-getOverConfirm (x:xs) = do-  b <- getConfirm x-  if b-    then getOverConfirm xs-    else return False---- | A yes-no confirmation.-getYesNo :: SingleFrame -> Action Bool-getYesNo frame = do-  fs <- getFrontendSession-  let keys = [ (K.Char 'y', K.NoModifier)-             , (K.Char 'n', K.NoModifier)-             , (K.Esc, K.NoModifier)-             ]-  (k, _) <- liftIO $ promptGetKey fs keys frame-  case k of-    K.Char 'y' -> return True-    _          -> return False---- TODO: perhaps add prompt to Report instead?-promptAdd :: Msg -> Msg -> Msg-promptAdd prompt msg = prompt <+> msg---- | Display a msg with a @more@ prompt. Return value indicates if the player--- tried to cancel/escape.-displayMore :: ColorMode -> Msg -> Action Bool-displayMore dm prompt = do-  let newPrompt = promptAdd prompt moreMsg-  frame <- drawPrompt dm newPrompt-  getConfirm frame---- | 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 :: Msg -> Action Bool-displayYesNo prompt = do-  frame <- drawPrompt ColorBW (promptAdd prompt yesnoMsg)-  getYesNo frame---- | Print a msg and several overlays, one per page.--- All frames require confirmations. Raise @abort@ if the player presses ESC.-displayOverAbort :: Msg -> [Overlay] -> Action ()-displayOverAbort prompt xs = do-  let newPrompt = promptAdd prompt ""-  let f x = drawOverlay ColorFull newPrompt (x ++ [moreMsg])-  frames <- mapM f xs-  go <- getOverConfirm frames-  when (not go) abort---- | Print a msg and several overlays, one per page.--- The last frame does not expect a confirmation and so does not show--- the invitation to press some keys.-displayOverlays :: Msg -> Msg -> [Overlay] -> ActionFrame ()-displayOverlays _      _ []  = returnNoFrame ()-displayOverlays prompt _ [x] = do-  frame <- drawOverlay ColorFull prompt x-  returnFrame frame-displayOverlays prompt pressKeys (x:xs) = do-  frame <- drawOverlay ColorFull (promptAdd prompt pressKeys) (x ++ [moreMsg])-  b <- getConfirm frame-  if b-    then displayOverlays prompt pressKeys xs-    else returnNoFrame ()---- | 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 :: Msg -> [Overlay] -> [(K.Key, K.Modifier)]-              -> Action (K.Key, K.Modifier)-displayChoiceUI prompt ovs keys = do-  let (over, rest, spc, more, keysS) = case ovs of-        [] -> ([], [], "", [], keys)-        [x] -> (x, [], "", [], keys)-        x:xs -> (x, xs, ", SPACE", [moreMsg], (K.Space, K.NoModifier) : keys)-      legalKeys =  (K.Esc, K.NoModifier) : keysS-  frame <- drawOverlay ColorFull (prompt <> spc <> ", ESC]") (over ++ more)-  fs <- getFrontendSession-  (key, modifier) <- liftIO $ promptGetKey fs legalKeys frame-  case key of-    K.Esc -> neverMind True-    K.Space | not (null rest) -> displayChoiceUI prompt rest keys-    _ -> return (key, modifier)---- | Push a frame or a single frame's worth of delay to the frame queue.-displayFramePush :: Maybe SingleFrame -> Action ()-displayFramePush mframe = do-  fs <- getFrontendSession-  liftIO $ displayFrame fs False mframe---- | Draw the current level. The prompt is displayed, but not added--- to history. The prompt is appended to the current message--- and only the first screenful of the resulting overlay is displayed.-drawPrompt :: ColorMode -> Msg -> Action SingleFrame-drawPrompt dm prompt = do-  cops <- getCOps-  per <- getPerception-  s <- get-  Diary{sreport} <- getDiary-  let over = splitReport $ addMsg sreport prompt-  return $ draw dm cops per s over---- | Draw the current level. The prompt and the overlay are displayed,--- but not added to history. The prompt is appended to the current message--- and only the first line of the result is displayed.--- The overlay starts on the second line.-drawOverlay :: ColorMode -> Msg -> Overlay -> Action SingleFrame-drawOverlay dm prompt overlay = do-  cops <- getCOps-  per <- getPerception-  s <- get-  Diary{sreport} <- getDiary-  let xsize = lxsize $ slevel s-      msgPrompt = renderReport $ addMsg sreport prompt-      over = padMsg xsize msgPrompt : overlay-  return $ draw dm cops per s over---- | Initialize perception, etc., display level and run the action.-startClip :: Action () -> Action ()-startClip action =-  -- Determine perception before running player command, in case monsters-  -- have opened doors, etc.-  withPerception $ do-    remember  -- heroes notice their surroundings, before they get displayed-    displayPush  -- draw the current surroundings-    action  -- let the actor act---- | Push the frame depicting the current level to the frame queue.--- Only one screenful of the report is shown, the rest is ignored.-displayPush :: Action ()-displayPush = do-  fs <- getFrontendSession-  s  <- get-  pl <- gets splayer-  frame <- drawPrompt ColorFull ""-  -- Visually speed up (by remving all empty frames) the show of the sequence-  -- of the move frames if the player is running.-  let (_, Actor{bdir}, _) = findActorAnyLevel pl s-      isRunning = isJust bdir-  liftIO $ displayFrame fs isRunning $ Just frame---- | Update heroes memory.-remember :: Action ()-remember = do-  per <- getPerception-  let vis = IS.toList (totalVisible per)-  rememberList vis---- | Update heroes memory at the given list of locations.-rememberList :: [Point] -> Action ()-rememberList vis = do-  Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getCOps-  lvl <- gets slevel-  let rememberTile = [(loc, lvl `at` loc) | loc <- vis]-      unknownId = ouniqGroup "unknown space"-      newClear (loc, tk) = lvl `rememberAt` loc == unknownId-                           && Tile.isExplorable cotile tk-      clearN = length $ filter newClear rememberTile-  modify (updateLevel (updateLRMap (Kind.// rememberTile)))-  modify (updateLevel (\ l@Level{lseen} -> l {lseen = lseen + clearN}))-  let alt Nothing      = Nothing-      alt (Just ([], _)) = Nothing-      alt (Just (t, _))  = Just (t, t)-      rememberItem = IM.alter alt-  modify (updateLevel (updateIMap (\ m -> foldr rememberItem m vis)))---- | Save the diary and a backup of the save game file, in case of crashes.------ See 'Save.saveGameBkp'.-saveGameBkp :: Action ()-saveGameBkp = do-  state <- get-  diary <- getDiary-  configUI <- getConfigUI-  liftIO $ Save.saveGameBkp configUI state diary---- | Dumps the current game rules configuration to a file.-dumpCfg :: FilePath -> Action ()-dumpCfg fn = do-  config <- gets sconfig-  liftIO $ ConfigIO.dump config fn---- | Handle current score and display it with the high scores.--- Aborts if display of the scores was interrupted by the user.------ Warning: scores are shown during the game,--- so we should be careful not to leak secret information through them--- (e.g., the nature of the items through the total worth of inventory).-handleScores :: Bool -> Status -> Int -> Action ()-handleScores write status total =-  when (total /= 0) $ do-    configUI <- getConfigUI-    time <- gets stime-    curDate <- liftIO getClockTime-    let score = register configUI write total time curDate status-    (placeMsg, slideshow) <- liftIO score-    displayOverAbort placeMsg slideshow---- | Continue or restart or exit the game.-endOrLoop :: Action () -> Action ()-endOrLoop handleTurn = do-  squit <- gets squit-  Kind.COps{coitem} <- getCOps-  s <- get-  configUI <- getConfigUI-  let (_, total) = calculateTotal coitem s-  -- The first, boolean component of squit determines-  -- if ending screens should be shown, the other argument describes-  -- the cause of the disruption of game flow.-  case squit of-    Nothing -> handleTurn  -- just continue-    Just (_, status@Camping) -> do-      -- Save and display in parallel.-      mv <- liftIO newEmptyMVar-      liftIO $ void $ forkIO (Save.saveGameFile configUI s-                              `finally` putMVar mv ())-      tryIgnore $ do-        handleScores False status total-        void $ displayMore ColorFull "See you soon, stronger and braver!"-      liftIO $ takeMVar mv  -- wait until saved-      -- Do nothing, that is, quit the game loop.-    Just (showScreens, status@Killed{}) -> do-      Diary{sreport} <- getDiary-      unless (nullReport sreport) $ do-        -- Sisplay any leftover report. Suggest it could be the cause of death.-        void $ displayMore ColorBW "Who would have thought?"-        recordHistory  -- prevent repeating the report-      tryWith-        (\ finalMsg ->-          let highScoreMsg = "Let's hope another party can save the day!"-              msg = if T.null finalMsg then highScoreMsg else finalMsg-          in void $ displayMore ColorBW msg-          -- Do nothing, that is, quit the game loop.-        )-        (do-           when showScreens $ handleScores True status total-           go <- displayMore ColorBW "Next time will be different."-           when (not go) $ abortWith "You could really win this time."-           restartGame handleTurn-        )-    Just (showScreens, status@Victor) -> do-      Diary{sreport} <- getDiary-      unless (nullReport sreport) $ do-        -- Sisplay any leftover report. Suggest it could be the master move.-        void $ displayMore ColorFull "Brilliant, wasn't it?"-        recordHistory  -- prevent repeating the report-      when showScreens $ do-        tryIgnore $ handleScores True status total-        void $ displayMore ColorFull "Can it be done better, though?"-      restartGame handleTurn-    Just (_, Restart) -> do-      void $ displayMore ColorBW "This time for real."-      restartGame handleTurn--restartGame :: Action () -> Action ()-restartGame handleTurn = do-  -- Take the original config from config file, to reroll RNG, if needed-  -- (the current config file has the RNG rolled for the previous game).-  configUI <- getConfigUI-  cops <- getCOps-  state <- gameResetAction configUI cops-  modify $ const state-  saveGameBkp-  handleTurn---- TODO: do this inside Action ()-gameReset :: ConfigUI -> Kind.COps -> IO State-gameReset configUI cops@Kind.COps{ coitem-                                 , corule-                                 , cofact=Kind.Ops{opick}} = do-  -- Rules config reloaded at each new game start.-  (configRules, dungeonGen, startingGen) <- ConfigIO.mkConfigRules corule-  let (DungeonState.FreshDungeon{..}, gen2) =-        runState (DungeonState.generate cops configRules) dungeonGen-      (sflavour, gen3) = runState (dungeonFlavourMap coitem) gen2-      factionName = configFaction configRules-      sfaction = evalState (opick factionName (const True)) gen3-  let state = defaultState configRules sfaction sflavour freshDungeon-                           entryLevel entryLoc startingGen-      hstate = initialHeroes cops entryLoc configUI state-  return hstate-gameResetAction :: ConfigUI -> Kind.COps -> Action State-gameResetAction configUI cops = liftIO $ gameReset configUI cops---- | Wire together content, the definitions of game commands,--- config and a high-level startup function--- to form the starting game session. Evaluate to check for errors,--- in particular verify content consistency.--- Then create the starting game config from the default config file--- and initialize the engine with the starting session.-startFrontend :: Kind.COps -> (ConfigUI -> Binding (ActionFrame ()))-              -> Action () -> IO ()-startFrontend !scops@Kind.COps{corule} stdBinding handleTurn = do-  -- UI config reloaded at each client start.-  sconfigUI <- ConfigIO.mkConfigUI corule-  let !sbinding = stdBinding sconfigUI-      font = configFont sconfigUI-      -- In addition to handling the turn, if the game ends or exits,-      -- handle the diary and backup savefile.-      handleGame = do-        handleTurn-        diary <- getDiary-        -- Save diary often, at each game exit, in case of crashes.-        liftIO $ Save.rmBkpSaveDiary sconfigUI diary-      loop sfs = start Session{..} handleGame-  startup font loop---- | Compute and insert auxiliary optimized components into game content,--- to be used in time-critical sections of the code.-speedupCops :: Session -> Session-speedupCops sess@Session{scops = cops@Kind.COps{cotile=tile}} =-  let ospeedup = Tile.speedup tile-      cotile = tile {Kind.ospeedup}-      scops = cops {Kind.cotile}-  in sess {scops}---- | Either restore a saved game, or setup a new game.--- Then call the main game loop.-start :: Session -> Action () -> IO ()-start slowSess handleGame = do-  let sess@Session{scops = cops@Kind.COps{corule}, sconfigUI} =-        speedupCops slowSess-      title = rtitle $ Kind.stdRuleset corule-      pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule-  restored <- Save.restoreGame sconfigUI pathsDataFile title-  case restored of-    Right (diary, msg) -> do  -- Starting a new game.-      state <- gameReset sconfigUI cops-      handlerToIO sess state-        diary{sreport = singletonReport msg}-        -- TODO: gameReset >> handleTurn or defaultState {squit=Reset}-        handleGame-    Left (state, diary, msg) ->  -- Running a restored game.-      handlerToIO sess state-        -- This overwrites the "Really save/quit?" messages.-        diary{sreport = singletonReport msg}-        handleGame---- | Debugging.-debug :: Text -> Action ()-debug _x = return () -- liftIO $ hPutStrLn stderr _x

@@ -1,214 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Game action monad and basic building blocks for player and monster--- actions. Exports 'liftIO' for injecting 'IO' into the 'Action' monad,--- but does not export the implementation of the Action monad.--- The 'liftIO' and 'handlerToIO' operations are used only in Action.hs.-{-# LANGUAGE MultiParamTypeClasses, RankNTypes #-}-module Game.LambdaHack.Action.ActionLift-  ( -- * Actions and basic operations-    ActionFun, Action, liftIO, handlerToIO, withPerception, getPerception-    -- * Actions returning frames-  , ActionFrame, returnNoFrame, returnFrame, whenFrame, inFrame-    -- * Game session and assessors to its components-  , Session(..), getFrontendSession, getCOps, getBinding, getConfigUI-    -- * Various ways to abort action-  , abort, abortWith, abortIfWith, neverMind-    -- * Abort exception handlers-  , tryWith, tryRepeatedlyWith, tryIgnore-    -- * Diary and report-  , getDiary, msgAdd, historyReset, msgReset-  ) where--import Control.Monad.State hiding (State, state, liftIO)-import qualified Data.List as L-import Data.Maybe-import qualified Data.Text as T--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.Perception-import Game.LambdaHack.Action.Frontend-import Game.LambdaHack.Msg-import Game.LambdaHack.State-import qualified Game.LambdaHack.Kind as Kind-import Game.LambdaHack.Binding-import Game.LambdaHack.Config-import Game.LambdaHack.Animation (SingleFrame(..))---- | The type of the function inside any action.--- (Separated from the @Action@ type to document each argument with haddock.)-type ActionFun r a =-   Session                           -- ^ session setup data-   -> DungeonPerception              -- ^ cached perception-   -> (State -> Diary -> a -> IO r)  -- ^ continuation-   -> (Msg -> IO r)                  -- ^ failure/reset continuation-   -> State                          -- ^ current state-   -> Diary                          -- ^ current diary-   -> IO r---- | Actions of player-controlled characters and of any other actors.-newtype Action a = Action-  { runAction :: forall r . ActionFun r a-  }--instance Show (Action a) where-  show _ = "an action"---- TODO: check if it's strict enough, if we don't keep old states for too long,--- Perhaps make state type fields strict for that, too?-instance Monad Action where-  return = returnAction-  (>>=)  = bindAction--instance Functor Action where-  fmap f (Action g) = Action (\ s p k a st ms ->-                               let k' st' ms' = k st' ms' . f-                               in g s p k' a st ms)--instance MonadState State Action where-  get     = Action (\ _s _p k _a  st ms -> k st  ms st)-  put nst = Action (\ _s _p k _a _st ms -> k nst ms ())---- | Invokes the action continuation on the provided argument.-returnAction :: a -> Action a-returnAction x = Action (\ _s _p k _a st m -> k st m x)---- | Distributes the session and shutdown continuation,--- threads the state and diary.-bindAction :: Action a -> (a -> Action b) -> Action b-bindAction m f = Action (\ s p k a st ms ->-                          let next nst nm x =-                                runAction (f x) s p k a nst nm-                          in runAction m s p next a st ms)---- Instance commented out, so that outside of Action/ nobody can--- subvert the Action monad by invoking arbitrary IO.---   instance MonadIO Action where-liftIO :: IO a -> Action a-liftIO x = Action (\ _s _p k _a st ms -> x >>= k st ms)---- | Run an action, with a given session, state and diary, in the @IO@ monad.-handlerToIO :: Session -> State -> Diary -> Action () -> IO ()-handlerToIO sess@Session{scops} state diary h =-  runAction h-    sess-    (dungeonPerception scops state)  -- create and cache perception-    (\ _ _ x -> return x)    -- final continuation returns result-    (\ msg ->  -- e.g., in AI code-      ioError $ userError $ T.unpack $ "unhandled abort:" <+> msg)-    state-    diary---- | Update the cached perception for the given computation.-withPerception :: Action () -> Action ()-withPerception h =-  Action (\ sess@Session{scops} _ k a st ms ->-           runAction h sess (dungeonPerception scops st) k a st ms)---- | Get the current perception.-getPerception :: Action Perception-getPerception = Action (\ _s per k _a s ms ->-                         k s ms (fromJust $ L.lookup (slid s) per))---- | Actions and screen frames, including delays, resulting--- from performing the actions.-type ActionFrame a = Action (a, [Maybe SingleFrame])---- | Return the value with an empty set of screen frames.-returnNoFrame :: a -> ActionFrame a-returnNoFrame a = return (a, [])---- | Return the trivial value with a single frame to show.-returnFrame :: SingleFrame -> ActionFrame ()-returnFrame fr = return ((), [Just fr])---- | As the @when@ monad operation, but on type @ActionFrame ()@.-whenFrame :: Bool -> ActionFrame () -> ActionFrame ()-whenFrame True x  = x-whenFrame False _ = returnNoFrame ()---- | Inject action into actions with screen frames.-inFrame :: Action () -> ActionFrame ()-inFrame act = act >> returnNoFrame ()---- | The information that is constant across a playing session,--- including many consecutive games in a single session,--- but is completely disregarded and reset when a new playing session starts.-data Session = Session-  { sfs       :: FrontendSession           -- ^ frontend session information-  , scops     :: Kind.COps                 -- ^ game content-  , sbinding  :: Binding (ActionFrame ())  -- ^ binding of keys to commands-  , sconfigUI :: ConfigUI                  -- ^ the UI config for this session-  }---- | Get the frontend session.-getFrontendSession :: Action FrontendSession-getFrontendSession = Action (\ Session{sfs} _p k _a st ms -> k st ms sfs)---- | Get the content operations.-getCOps :: Action Kind.COps-getCOps = Action (\ Session{scops} _p k _a st ms -> k st ms scops)---- | Get the key binding.-getBinding :: Action (Binding (ActionFrame ()))-getBinding = Action (\ Session{sbinding} _p k _a st ms -> k st ms sbinding)---- | Get the config from the config file.-getConfigUI :: Action ConfigUI-getConfigUI = Action (\ Session{sconfigUI} _p k _a st ms -> k st ms sconfigUI)---- | Reset the state and resume from the last backup point, i.e., invoke--- the failure continuation.-abort :: Action a-abort = abortWith ""---- | Abort with the given message.-abortWith :: Msg -> Action a-abortWith msg = Action (\ _s _p _k a _st _ms -> a msg)---- | Abort and print the given msg if the condition is true.-abortIfWith :: Bool -> Msg -> Action a-abortIfWith True msg = abortWith msg-abortIfWith False _  = abortWith ""---- | Abort and conditionally print the fixed message.-neverMind :: Bool -> Action a-neverMind b = abortIfWith b "never mind"---- | Set the current exception handler. First argument is the handler,--- second is the computation the handler scopes over.-tryWith :: (Msg -> Action a) -> Action a -> Action a-tryWith exc h = Action (\ s p k a st ms ->-                         let runA msg = runAction (exc msg) s p k a st ms-                         in runAction h s p k runA st ms)---- | Take a handler and a computation. If the computation fails, the--- handler is invoked and then the computation is retried.-tryRepeatedlyWith :: (Msg -> Action ()) -> Action () -> Action ()-tryRepeatedlyWith exc h =-  tryWith (\ msg -> exc msg >> tryRepeatedlyWith exc h) h---- | Try the given computation and silently catch failure.-tryIgnore :: Action () -> Action ()-tryIgnore =-  tryWith (\ msg -> if T.null msg-                    then return ()-                    else assert `failure` msg <+> "in tryIgnore")---- | Get the current diary.-getDiary :: Action Diary-getDiary = Action (\ _s _p k _a st diary -> k st diary diary)---- | Add a message to the current report.-msgAdd :: Msg -> Action ()-msgAdd nm = Action (\ _s _p k _a st ms ->-                     k st ms{sreport = addMsg (sreport ms) nm} ())---- | Wipe out and set a new value for the history.-historyReset :: History -> Action ()-historyReset shistory = Action (\ _s _p k _a st Diary{sreport} ->-                                 k st Diary{..} ())---- | Wipe out and set a new value for the current report.-msgReset :: Msg -> Action ()-msgReset nm = Action (\ _s _p k _a st ms ->-                       k st ms{sreport = singletonReport nm} ())

@@ -1,190 +0,0 @@--- | Personal game configuration file support.-module Game.LambdaHack.Action.ConfigIO-  ( mkConfigRules, mkConfigUI, dump-  ) where--import System.Directory-import System.FilePath-import System.Environment-import qualified Data.ConfigFile as CF-import qualified Data.Char as Char-import Data.List-import qualified System.Random as R-import qualified Data.Text as T--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.Config-import qualified Game.LambdaHack.Key as K-import qualified Game.LambdaHack.Kind as Kind-import Game.LambdaHack.Content.RuleKind--overrideCP :: CP -> FilePath -> IO CP-overrideCP cp@(CP defCF) cfile = do-  b <- doesFileExist cfile-  if not b-    then return cp-    else do-      c <- CF.readfile defCF cfile-      return $ toCP $ 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 CPP.--- 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 = 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: " ++ s ++ "." ++ o-  else CP $ forceEither $ CF.set conf s o v---- | Gets a random generator from the config or,--- if not present, generates one and updates the config with it.-getSetGen :: CP      -- ^ config-          -> String  -- ^ name of the generator-          -> IO (R.StdGen, CP)-getSetGen config option =-  case getOption config "engine" option of-    Just sg -> return (read sg, config)-    Nothing -> do-      -- Pick the randomly chosen generator from the IO monad-      -- and record it in the config for debugging (can be 'D'umped).-      g <- R.newStdGen-      let gs = show g-          c = set config "engine" option gs-      return (g, c)---- | 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}---- | In case of corruption, just fail.-forceEither :: Show a => Either a b -> b-forceEither (Left a)  = assert `failure` a-forceEither (Right b) = b---- | A simplified access to an option in a given section,--- with simple error reporting (no internal errors are caught nor hidden).--- If there is no such option, gives Nothing.-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 $ 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 forceEither $ CF.get conf s o-  else assert `failure` "Unknown config option: " ++ s ++ "." ++ o---- | An association list corresponding to a section. Fails if no such section.-getItems :: CP -> CF.SectionSpec -> [(String, String)]-getItems (CP conf) s =-  if CF.has_section conf s-  then forceEither $ CF.items conf s-  else assert `failure` "Unknown config section: " ++ s--parseConfigRules :: CP -> Config-parseConfigRules cp =-  let configSelfString = let CP conf = cp in CF.to_string conf-      configCaves = map (\(n, t) -> (T.pack n, T.pack t)) $ getItems cp "caves"-      configDepth = get cp "dungeon" "depth"-      configFovMode = get cp "engine" "fovMode"-      configSmellTimeout = get cp "engine" "smellTimeout"-      configBaseHP = get cp "heroes" "baseHP"-      configExtraHeroes = get cp "heroes" "extraHeroes"-      configFirstDeathEnds = get cp "heroes" "firstDeathEnds"-      configFaction = T.pack $ get cp "heroes" "faction"-  in Config{..}--parseConfigUI :: FilePath -> CP -> ConfigUI-parseConfigUI dataDir cp =-  let mkKey s =-        case K.keyTranslate s of-          K.Unknown _ ->-            assert `failure` ("unknown config file key <" ++ s ++ ">")-          key -> key-      configCommands =-        let mkCommand (key, def) = (mkKey key, def)-            section = getItems cp "commands"-        in map mkCommand section-      configAppDataDir = dataDir-      configDiaryFile = dataDir </> get cp "files" "diaryFile"-      configSaveFile = dataDir </> get cp "files" "saveFile"-      configBkpFile = dataDir </> get cp "files" "saveFile" <.> ".bkp"-      configScoresFile = dataDir </> get cp "files" "scoresFile"-      configRulesCfgFile = dataDir </> "config.rules"-      configUICfgFile = dataDir </> "config.ui"-      configHeroNames =-        let toNumber (ident, name) =-              case stripPrefix "HeroName_" ident of-                Just n -> (read n, T.pack name)-                Nothing -> assert `failure` ("wrong hero name id " ++ ident)-            section = getItems cp "heroNames"-        in map toNumber section-      configMacros =-        let trMacro (from, to) =-              let !fromTr = mkKey from-                  !toTr  = mkKey to-              in if fromTr == toTr-                 then assert `failure` "degenerate alias: " ++ show toTr-                 else (fromTr, toTr)-            section = getItems cp "macros"-        in map trMacro section-      configFont = get cp "ui" "font"-      configHistoryMax = get cp "ui" "historyMax"-  in ConfigUI{..}---- | Read and parse rules config file and supplement it with random seeds.-mkConfigRules :: Kind.Ops RuleKind -> IO (Config, R.StdGen, R.StdGen)-mkConfigRules corule = do-  let cpRulesDefault = rcfgRulesDefault $ Kind.stdRuleset corule-  appData <- appDataDir-  cpRules <- mkConfig cpRulesDefault $ appData </> "config.rules.ini"-  (dungeonGen,  cp2) <- getSetGen cpRules "dungeonRandomGenerator"-  (startingGen, cp3) <- getSetGen cp2     "startingRandomGenerator"-  return (parseConfigRules cp3, dungeonGen, startingGen)---- | Read and parse UI config file.-mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI-mkConfigUI corule = do-  let cpUIDefault = rcfgUIDefault $ Kind.stdRuleset corule-  appData <- appDataDir-  cpUI <- mkConfig cpUIDefault $ appData </> "config.ui.ini"-  return $ parseConfigUI appData cpUI

@@ -1,33 +0,0 @@--- | Display game data on the screen and receive user input--- using one of the available raw frontends and derived  operations.-module Game.LambdaHack.Action.Frontend-  ( -- * Re-exported part of the raw frontend-    FrontendSession, startup, frontendName, nextEvent-    -- * Derived operations-  , displayFrame, promptGetKey-  ) where--import Game.LambdaHack.Action.Frontend.Chosen-import qualified Game.LambdaHack.Key as K (Key, Modifier)-import Game.LambdaHack.Animation (SingleFrame(..))---- | Push a frame or a single frame's worth of delay to the frame queue.-displayFrame :: FrontendSession -> Bool -> Maybe SingleFrame -> IO ()-displayFrame fs isRunning = display fs True isRunning---- TODO: move promptGetKey here and then change its type to--- promptGetKey :: FrontendSession---              -> [((K.Key, K.Modifier), a)]---              -> ((K.Key, K.Modifier) -> a)  -- ^ handle unexpected key---              -> SingleFrame---              -> IO a--- Then see if it can be used instead of the dangerous, low level nextEvent.--- | Display a prompt, wait for any of the specified keys (for any key,--- if the list is empty). Repeat if an unexpected key received.-promptGetKey :: FrontendSession -> [(K.Key, K.Modifier)] -> SingleFrame-             -> IO (K.Key, K.Modifier)-promptGetKey sess keys frame = do-  km <- promptGetAnyKey sess frame-  if null keys || km `elem` keys-    then return km-    else promptGetKey sess keys frame

@@ -1,21 +0,0 @@--- | Re-export the operations of the chosen raw frontend--- (determined at compile time with cabal flags).-{-# LANGUAGE CPP #-}-module Game.LambdaHack.Action.Frontend.Chosen-  ( -- * Re-exported raw frontend-    FrontendSession, startup, frontendName, nextEvent, promptGetAnyKey, display-  ) where---- Wrapper for selected Display frontend.--#ifdef GTK-import Game.LambdaHack.Action.Frontend.Gtk as D-#elif VTY-import Game.LambdaHack.Action.Frontend.Vty as D-#elif CURSES-import Game.LambdaHack.Action.Frontend.Curses as D-#elif STD-import Game.LambdaHack.Action.Frontend.Std as D-#else-import Game.LambdaHack.Action.Frontend.Gtk as D-#endif

@@ -1,158 +0,0 @@--- | Text frontend based on HSCurses.-module Game.LambdaHack.Action.Frontend.Curses-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , display, nextEvent, promptGetAnyKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import qualified UI.HSCurses.Curses as C-import qualified UI.HSCurses.CursesHelper as C-import qualified Data.List as L-import qualified Data.Map as M-import Control.Monad-import Data.Char (ord, chr)-import qualified Data.Text as T--import Game.LambdaHack.Utils.Assert-import qualified Game.LambdaHack.Key as K (Key(..),  Modifier(..))-import qualified Game.LambdaHack.Color as Color-import Game.LambdaHack.Animation (SingleFrame(..))---- | Session data maintained by the frontend.-data FrontendSession = FrontendSession-  { swin    :: C.Window  -- ^ the window to draw to-  , sstyles :: M.Map Color.Attr C.CursesStyle-      -- ^ map from fore/back colour pairs to defined curses styles-  }---- | The name of the frontend.-frontendName :: String-frontendName = "curses"---- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = do-  C.start---  C.keypad C.stdScr False  -- TODO: may help to fix xterm keypad on Ubuntu-  void $ C.cursSet C.CursorInvisible-  let s = [ (Color.Attr{fg, bg}, C.Style (toFColor fg) (toBColor bg))-          | fg <- [minBound..maxBound],-            -- No more color combinations possible: 16*4, 64 is max.-            bg <- Color.legalBG ]-  nr <- C.colorPairs-  when (nr < L.length s) $-    C.end >>-    (assert `failure`-       "Terminal has too few color pairs (" ++ show nr ++ "). Giving up.")-  let (ks, vs) = unzip s-  ws <- C.convertStyles vs-  let styleMap = M.fromList (zip ks ws)-  k (FrontendSession C.stdScr styleMap)-  C.end---- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data-        -> Bool-        -> Bool-        -> Maybe SingleFrame  -- ^ the screen frame to draw-        -> IO ()-display _ _ _ Nothing = return ()-display FrontendSession{..}  _ _ (Just SingleFrame{..}) = do-  -- let defaultStyle = C.defaultCursesStyle-  -- Terminals with white background require this:-  let defaultStyle = sstyles M.! Color.defaultAttr-  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-  sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles)-              >> C.mvWAddStr swin (y + 1) x [acChar]-            | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ]-  C.refresh---- | Input key via the frontend.-nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier)-nextEvent _sess _ = keyTranslate `fmap` C.getKey C.refresh---- | Display a prompt, wait for any key.-promptGetAnyKey :: FrontendSession -> SingleFrame-             -> IO (K.Key, K.Modifier)-promptGetAnyKey sess frame = do-  display sess True True $ Just frame-  nextEvent sess Nothing--keyTranslate :: C.Key -> (K.Key, K.Modifier)-keyTranslate e =-  case e of-    C.KeyChar '\ESC' -> (K.Esc,     K.NoModifier)-    C.KeyExit        -> (K.Esc,     K.NoModifier)-    C.KeyChar '\n'   -> (K.Return,  K.NoModifier)-    C.KeyChar '\r'   -> (K.Return,  K.NoModifier)-    C.KeyEnter       -> (K.Return,  K.NoModifier)-    C.KeyChar ' '    -> (K.Space,   K.NoModifier)-    C.KeyChar '\t'   -> (K.Tab,     K.NoModifier)-    C.KeyBTab        -> (K.BackTab, K.NoModifier)-    C.KeyUp          -> (K.Up,      K.NoModifier)-    C.KeyDown        -> (K.Down,    K.NoModifier)-    C.KeyLeft        -> (K.Left,    K.NoModifier)-    C.KeySLeft       -> (K.Left,    K.NoModifier)-    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.KeyNPage       -> (K.PgDn,    K.NoModifier)-    C.KeyBeg         -> (K.Begin,   K.NoModifier)-    C.KeyB2          -> (K.Begin,   K.NoModifier)-    C.KeyClear       -> (K.Begin,   K.NoModifier)-    -- No KP_ keys; see https://github.com/skogsbaer/hscurses/issues/10-    -- TODO: try to get the Control modifier for keypad keys from the escape-    -- gibberish and use Control-keypad for KP_ movement.-    C.KeyChar c-      -- This case needs to be considered after Tab, since, apparently,-      -- on some terminals ^i == Tab and Tab is more important for us.-      | ord '\^A' <= ord c && ord c <= ord '\^Z' ->-        -- Alas, only lower-case letters.-        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)-        -- Movement keys are more important than hero selection,-        -- so disabling the latter and interpreting the keypad numbers-        -- as movement:-      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)-      | otherwise           -> (K.Char c,            K.NoModifier)-    _                       -> (K.Unknown (show e),  K.NoModifier)--toFColor :: Color.Color -> C.ForegroundColor-toFColor Color.Black     = C.BlackF-toFColor Color.Red       = C.DarkRedF-toFColor Color.Green     = C.DarkGreenF-toFColor Color.Brown     = C.BrownF-toFColor Color.Blue      = C.DarkBlueF-toFColor Color.Magenta   = C.PurpleF-toFColor Color.Cyan      = C.DarkCyanF-toFColor Color.White     = C.WhiteF-toFColor Color.BrBlack   = C.GreyF-toFColor Color.BrRed     = C.RedF-toFColor Color.BrGreen   = C.GreenF-toFColor Color.BrYellow  = C.YellowF-toFColor Color.BrBlue    = C.BlueF-toFColor Color.BrMagenta = C.MagentaF-toFColor Color.BrCyan    = C.CyanF-toFColor Color.BrWhite   = C.BrightWhiteF--toBColor :: Color.Color -> C.BackgroundColor-toBColor Color.Black     = C.BlackB-toBColor Color.Red       = C.DarkRedB-toBColor Color.Green     = C.DarkGreenB-toBColor Color.Brown     = C.BrownB-toBColor Color.Blue      = C.DarkBlueB-toBColor Color.Magenta   = C.PurpleB-toBColor Color.Cyan      = C.DarkCyanB-toBColor Color.White     = C.WhiteB-toBColor _               = C.BlackB  -- a limitation of curses

@@ -1,463 +0,0 @@--- | Text frontend based on Gtk.-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-module Game.LambdaHack.Action.Frontend.Gtk-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , display, nextEvent, promptGetAnyKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Monad-import Control.Monad.Reader-import Control.Concurrent-import Control.Exception (finally)-import Graphics.UI.Gtk.Gdk.EventM-import Graphics.UI.Gtk hiding (Point)-import qualified Data.List as L-import Data.IORef-import Data.Maybe-import qualified Data.Map as M-import qualified Data.ByteString.Char8 as BS-import System.Time-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8)--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.Utils.LQueue-import qualified Game.LambdaHack.Key as K (Key(..), keyTranslate, Modifier(..))-import qualified Game.LambdaHack.Color as Color-import Game.LambdaHack.Animation (SingleFrame(..))--data FrameState =-    FPushed  -- frames stored in a queue, to be drawn in equal time intervals-      { fpushed :: !(LQueue (Maybe GtkFrame))  -- ^ screen output channel-      , fshown  :: !GtkFrame                   -- ^ last full frame shown-      }-  | FSet  -- a single frame stored, to be drawn when a keypress is requested-      { fsetFrame :: !(Maybe GtkFrame)  -- ^ frame to draw at input key-      }-  | FNone  -- no frames stored---- | Session data maintained by the frontend.-data FrontendSession = FrontendSession-  { sview       :: !TextView                    -- ^ the widget to draw to-  , stags       :: !(M.Map Color.Attr TextTag)  -- ^ text color tags for fg/bg-  , schanKey    :: !(Chan (K.Key, K.Modifier))  -- ^ channel for keyboard input-  , sframeState :: !(MVar FrameState)           -- ^ state of the frame machine-  , slastFull   :: !(IORef (GtkFrame, Bool))-       -- ^ most recent full (not empty, not repeated) frame received-       -- and if any empty frame followed it-  }--data GtkFrame = GtkFrame-  { gfChar :: !BS.ByteString-  , gfAttr :: ![[TextTag]]-  }-  deriving Eq--dummyFrame :: GtkFrame-dummyFrame = GtkFrame BS.empty []---- | Remove all but the last element of the frame queue.--- The kept last element ensures that slastFull is not invalidated.-trimQueue :: FrontendSession -> IO ()-trimQueue FrontendSession{sframeState} = do-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      putMVar sframeState FPushed{fpushed = trimLQueue fpushed, ..}-    _ ->-      putMVar sframeState fs---- | The name of the frontend.-frontendName :: String-frontendName = "gtk"---- | Spawns the gtk input and output thread, which spawns all the other--- required threads. We create a separate thread for gtk to minimize--- communication with the heavy main thread. The other threads have to be--- spawned after gtk is initialized, because they call @postGUIAsync@,--- and need @sview@ and @stags@.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup configFont k = do-  mv <- newEmptyMVar-  -- Fork the gtk input and output thread.-  -- TODO: when GHC changes, make sure GTK is still faster on its own thread.-  void $ forkIO (runGtk configFont k `finally` putMVar mv ())-  takeMVar mv---- | Sets up and starts the main GTK loop providing input and output.-runGtk :: String ->  (FrontendSession -> IO ()) -> IO ()-runGtk configFont k = do-  -- Init GUI.-  unsafeInitGUIForThreadedRTS-  -- Text attributes.-  ttt <- textTagTableNew-  stags <- fmap M.fromList $-             mapM (\ ak -> do-                      tt <- textTagNew Nothing-                      textTagTableAdd ttt tt-                      doAttr tt ak-                      return (ak, tt))-               [ Color.Attr{fg, bg}-               | fg <- [minBound..maxBound], bg <- Color.legalBG ]-  -- Text buffer.-  tb <- textBufferNew (Just ttt)-  -- Create text view. TODO: use GtkLayout or DrawingArea instead of TextView?-  sview <- textViewNewWithBuffer tb-  textViewSetEditable sview False-  textViewSetCursorVisible sview False-  -- Set up the channel for keyboard input.-  schanKey <- newChan-  -- Set up the frame state.-  let frameState = FNone-  -- Create the session record.-  sframeState <- newMVar frameState-  slastFull <- newIORef (dummyFrame, False)-  let sess = FrontendSession{..}-  -- Fork the game logic thread. When logic ends, game exits.-  -- TODO: is postGUIAsync needed here?-  forkIO $ k sess >> postGUIAsync mainQuit-  -- Fork the thread that periodically draws a frame from a queue, if any.-  forkIO $ pollFrames sess Nothing-  -- Fill the keyboard channel.-  sview `on` keyPressEvent $ do-    n <- eventKeyName-    mods <- eventModifier-    let !key = K.keyTranslate n-        !modifier = modifierTranslate mods-    liftIO $ do-      unless (deadKey n) $ do-        -- Drop all the old frames. Some more may be arriving at the same time.-        trimQueue sess-        -- Store the key in the channel.-        writeChan schanKey (key, modifier)-      return True-  -- Set the font specified in config, if any.-  f <- fontDescriptionFromString configFont-  widgetModifyFont sview (Just f)-  -- Prepare font chooser dialog.-  currentfont <- newIORef f-  sview `on` buttonPressEvent $ do-    but <- eventButton-    liftIO $ case but of-      RightButton -> do-        fsd <- fontSelectionDialogNew "Choose font"-        cf  <- readIORef currentfont  -- TODO: "Terminus,Monospace" fails-        fds <- fontDescriptionToString cf-        fontSelectionDialogSetFontName fsd fds-        fontSelectionDialogSetPreviewText fsd "eee...@.##+##"-        resp <- dialogRun fsd-        when (resp == ResponseOk) $ do-          fn <- fontSelectionDialogGetFontName fsd-          case fn of-            Just fn' -> do-              fd <- fontDescriptionFromString fn'-              writeIORef currentfont fd-              widgetModifyFont sview (Just fd)-            Nothing  -> return ()-        widgetDestroy fsd-        return True-      _ -> return False-  -- Modify default colours.-  let black = Color minBound minBound minBound  -- Color.defBG == Color.Black-      white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White-  widgetModifyBase sview StateNormal black-  widgetModifyText sview StateNormal white-  -- Set up the main window.-  w <- windowNew-  containerAdd w sview-  onDestroy w mainQuit-  widgetShowAll w-  -- Wait until the other thread draws something and show the window.-  yield-  mainGUI---- | Output to the screen via the frontend.-output :: FrontendSession  -- ^ frontend session data-       -> GtkFrame         -- ^ the screen frame to draw-       -> IO ()-output FrontendSession{sview, stags} GtkFrame{..} = do  -- new frame-  tb <- textViewGetBuffer sview-  let attrs = L.zip [0..] gfAttr-      defaultAttr = stags M.! Color.defaultAttr-  textBufferSetByteString tb gfChar-  mapM_ (setTo tb defaultAttr 0) attrs--setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO ()-setTo _  _   _  (_,  [])         = return ()-setTo tb defaultAttr lx (ly, attr:attrs) = do-  ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx-  ie <- textIterCopy ib-  let setIter :: TextTag -> Int -> [TextTag] -> IO ()-      setIter previous repetitions [] = do-        textIterForwardChars ie repetitions-        when (previous /= defaultAttr) $-          textBufferApplyTag tb previous ib ie-      setIter previous repetitions (a:as)-        | a == previous =-            setIter a (repetitions + 1) as-        | otherwise = do-            textIterForwardChars ie repetitions-            when (previous /= defaultAttr) $-              textBufferApplyTag tb previous ib ie-            textIterForwardChars ib repetitions-            setIter a 1 as-  setIter attr 1 attrs---- TODO: configure--- | Maximal frames per second.--- This is better low and fixed, to avoid jerkiness and delays--- that tell the player there are many intelligent enemies on the level.--- That's better than scaling AI sofistication down based on the FPS setting--- and machine speed.-maxFps :: Int-maxFps = 15---- | Maximal polls per second.-maxPolls :: Int-maxPolls = let maxP = 120-           in assert (maxP >= 2 * maxFps `blame` (maxP, maxFps)) $-              maxP---- | Add a given number of microseconds to time.-addTime :: ClockTime -> Int -> ClockTime-addTime (TOD s p) ms = TOD s (p + fromIntegral (ms * 1000000))---- | The difference between the first and the second time, in microseconds.-diffTime :: ClockTime -> ClockTime -> Int-diffTime (TOD s1 p1) (TOD s2 p2) =-  (fromIntegral $ s1 - s2) * 1000000 +-  (fromIntegral $ p1 - p2) `div` 1000000---- | Poll the frame queue often and draw frames at fixed intervals.-pollFrames :: FrontendSession -> Maybe ClockTime -> IO ()-pollFrames sess (Just setTime) = do-  -- Check if the time is up.-  curTime <- getClockTime-  let diffT = diffTime setTime curTime-  if diffT > 1000000 `div` maxPolls-    then do-      -- Delay half of the time difference.-      threadDelay $ diffTime curTime setTime `div` 2-      pollFrames sess $ Just setTime-    else-      -- Don't delay, because time is up!-      pollFrames sess Nothing-pollFrames sess@FrontendSession{sframeState} Nothing = do-  -- Time time is up, check if we actually wait for anyting.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      case tryReadLQueue fpushed of-        Just (Just frame, queue) -> do-          -- The frame has arrived so send it for drawing and update delay.-          putMVar sframeState FPushed{fpushed = queue, fshown = frame}-          postGUIAsync $ output sess frame-          curTime <- getClockTime-          threadDelay $ 1000000 `div` (maxFps * 2)-          pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps-        Just (Nothing, queue) -> do-          -- Delay requested via an empty frame.-          putMVar sframeState FPushed{fpushed = queue, ..}-          curTime <- getClockTime-          -- There is no problem if the delay is a bit delayed.-          threadDelay $ 1000000 `div` maxFps-          pollFrames sess $ Just $ addTime curTime $ 1000000 `div` maxFps-        Nothing -> do-          -- The queue is empty, the game logic thread lags.-          putMVar sframeState fs-          -- Time time is up, the game thread is going to send a frame,-          -- (otherwise it would change the state), so poll often.-          threadDelay $ 1000000 `div` maxPolls-          pollFrames sess Nothing-    _ -> do-      putMVar sframeState fs-      -- Not in the Push state, so poll lazily to catch the next state change.-      -- The slow polling also gives the game logic a head start-      -- in creating frames in case one of the further frames is slow-      -- to generate and would normally cause a jerky delay in drawing.-      threadDelay $ 1000000 `div` (maxFps * 2)-      pollFrames sess Nothing---- | Add a frame to be drawn.-display :: FrontendSession -> Bool -> Bool -> Maybe SingleFrame -> IO ()-display sess True noDelay rawFrame = pushFrame sess noDelay rawFrame-display sess False _ (Just rawFrame) = setFrame sess rawFrame-display _ _ _ _ = assert `failure` "display: empty frame to be set"---- | Add a game screen frame to the frame drawing channel.-pushFrame :: FrontendSession -> Bool -> Maybe SingleFrame -> IO ()-pushFrame sess@FrontendSession{sframeState, slastFull} noDelay rawFrame = do-  -- Full evaluation and comparison is done outside the mvar lock.-  (lastFrame, anyFollowed) <- readIORef slastFull-  let frame = maybe Nothing (Just . evalFrame sess) rawFrame-      nextFrame =-        if frame == Just lastFrame-        then Nothing  -- no sense repeating-        else frame-  -- Now we take the lock.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      if (isNothing nextFrame && anyFollowed)-      then putMVar sframeState fs  -- old news-      else putMVar sframeState-             FPushed{fpushed = writeLQueue fpushed nextFrame, ..}-    FSet{} -> assert `failure` "pushFrame: FSet, expecting FPushed or FNone"-    FNone ->-      -- Never start playing with an empty frame.-      let fpushed = if isJust nextFrame-                    then writeLQueue newLQueue nextFrame-                    else newLQueue-          fshown = dummyFrame-      in putMVar sframeState FPushed{..}-  yield  -- drawing has priority-  case nextFrame of-    Nothing -> writeIORef slastFull (lastFrame, True)-    Just f  -> writeIORef slastFull (f, noDelay)--evalFrame :: FrontendSession -> SingleFrame -> GtkFrame-evalFrame FrontendSession{stags} SingleFrame{..} =-  let levelChar = L.map (T.pack . L.map Color.acChar) sfLevel-      gfChar = encodeUtf8 $ T.intercalate (T.singleton '\n')-               $ sfTop : levelChar ++ [sfBottom]-      -- Strict version of @L.map (L.map ((stags M.!) . fst)) sfLevel@.-      gfAttr  = L.reverse $ L.foldl' ff [] sfLevel-      ff ll l = (L.reverse $ L.foldl' f [] l) : ll-      f l ac  = let !tag = stags M.! Color.acAttr ac in tag : l-  in GtkFrame{..}---- | Set the frame to be drawn at the next invocation of @nextEvent@.--- Fail if there is already a frame pushed or set.--- Don't show the frame if it's unchanged vs the previous.-setFrame :: FrontendSession -> SingleFrame -> IO ()-setFrame sess@FrontendSession{slastFull, sframeState} rawFrame = do-  -- Full evaluation and comparison is done outside the mvar lock.-  (lastFrame, _) <- readIORef slastFull-  let frame = evalFrame sess rawFrame-      fsetFrame =-        if frame == lastFrame-        then Nothing  -- no sense repeating-        else Just frame-  -- Now we take the lock.-  fs <- takeMVar sframeState-  case fs of-    FPushed{} -> assert `failure` "setFrame: FPushed, expecting FNone"-    FSet{} -> assert `failure` "setFrame: FSet, expecting FNone"-    FNone -> do-      -- Update the last received frame with the processed frame.-      -- There is no race condition, because we are on the same thread-      -- as pushFrame.-      maybe (return ()) (\ fr -> writeIORef slastFull (fr, False)) fsetFrame-  -- Store the frame. Release the lock.-  putMVar sframeState FSet{..}---- | Input key via the frontend. Fail if there is no frame to show--- to the player as a prompt for the keypress.-nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier)-nextEvent FrontendSession{schanKey, sframeState} Nothing = do-  -- Verify the state.-  -- Assumption: no other thread changes the main constructor in sframeState.-  fs <- readMVar sframeState-  case fs of-    FNone     -> return ()  -- old frame requested, as expected-    FPushed{} -> assert `failure` "nextEvent: FPushed, expecting FNone"-    FSet{}    -> assert `failure` "nextEvent: FSet, expecting FNone"-  -- Wait for a keypress.-  km <- readChan schanKey-  return km-nextEvent sess@FrontendSession{schanKey, sframeState} (Just False) = do-  -- Take the lock to display the set frame.-  fs <- takeMVar sframeState-  case fs of-    FSet{fsetFrame} -> do-      -- If the frame not repeated, draw it.-      maybe (return ()) (postGUIAsync . output sess) fsetFrame-    FPushed{} -> assert `failure` "nextEvent: FPushed, expecting FSet"-    FNone     -> assert `failure` "nextEvent: FNone, expecting FSet"-  -- Clear the stored frame. Release the lock.-  putMVar sframeState FNone-  -- Wait for a keypress.-  km <- readChan schanKey-  return km-nextEvent sess@FrontendSession{schanKey, sframeState} (Just True) = do-  -- Wait for a keypress.-  km <- readChan schanKey-  -- Trim the queue.-  trimQueue sess-  -- Take the lock to wipe out the frame queue, unless it's empty already.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} -> do-      -- Draw the last frame ASAP.-      case tryReadLQueue fpushed of-        Just (Just frame, queue) -> assert (nullLQueue queue) $ do-          -- Comparison is done inside the mvar lock, this time, but it's OK.-          let lastFrame = fshown-              nextFrame =-                if frame == lastFrame-                then Nothing  -- no sense repeating-                else Just frame-          maybe (return ()) (postGUIAsync . output sess) nextFrame-        Just (Nothing, _) ->  assert `failure` "nextEvent: trimmed queue"-        Nothing -> return ()-    FSet{} -> assert `failure` "nextEvent: FSet, expecting FPushed"-    FNone  -> assert `failure` "nextEvent: FNone, expecting FPushed"-  -- Wipe out the frame queue. No more frames will arrive, because we are-  -- on the same thread as pushFrame. Release the lock.-  putMVar sframeState FNone-  return km---- | Display a prompt, wait for any key.--- Starts in Push or None mode, stop in None mode.--- Spends most time waiting for a key, so not performance critical,--- so does not need optimization.-promptGetAnyKey :: FrontendSession -> SingleFrame-                -> IO (K.Key, K.Modifier)-promptGetAnyKey sess@FrontendSession{sframeState} frame = do-  -- Assumption: no other thread changes the main constructor in sframeState.-  fs <- readMVar sframeState-  yield  -- drawing has priority-  let doPush = case fs of-        FPushed{} -> True-        FSet{}    ->-          assert `failure` "promptGetKey: FSet, expecting FPushed or FNone"-        FNone     -> False-  display sess doPush True $ Just frame-  nextEvent sess (Just doPush)---- | Tells a dead key.-deadKey :: String -> Bool-deadKey x = case x of-  "Shift_R"          -> True-  "Shift_L"          -> True-  "Control_L"        -> True-  "Control_R"        -> True-  "Super_L"          -> True-  "Super_R"          -> True-  "Menu"             -> True-  "Alt_L"            -> True-  "Alt_R"            -> True-  "ISO_Level2_Shift" -> True-  "ISO_Level3_Shift" -> True-  "ISO_Level2_Latch" -> True-  "ISO_Level3_Latch" -> True-  "Num_Lock"         -> True-  "Caps_Lock"        -> True-  _                  -> False---- | Translates modifiers to our own encoding.-modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods =-  if Control `elem` mods then K.Control else K.NoModifier--doAttr :: TextTag -> Color.Attr -> IO ()-doAttr tt attr@Color.Attr{fg, bg}-  | attr == Color.defaultAttr = return ()-  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]-  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]-  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,-                                textTagBackground := Color.colorToRGB bg]

@@ -1,107 +0,0 @@--- | Text frontend based on stdin/stdout, intended for bots.-module Game.LambdaHack.Action.Frontend.Std-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , display, nextEvent, promptGetAnyKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import qualified Data.List as L-import qualified Data.ByteString.Char8 as BS-import qualified System.IO as SIO-import Data.Text.Encoding (encodeUtf8)--import qualified Game.LambdaHack.Key as K (Key(..),  Modifier(..))-import qualified Game.LambdaHack.Color as Color-import Game.LambdaHack.Animation (SingleFrame(..))---- | No session data needs to be maintained by this frontend.-type FrontendSession = ()---- | The name of the frontend.-frontendName :: String-frontendName = "std"---- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = k ()---- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data-        -> Bool-        -> Bool-        -> Maybe SingleFrame  -- ^ the screen frame to draw-        -> IO ()-display _ _ _ Nothing = return ()-display _ _ _ (Just SingleFrame{..}) =-  let chars = L.map (BS.pack . L.map Color.acChar) sfLevel-      bs = [encodeUtf8 sfTop, BS.empty] ++ chars ++ [encodeUtf8 sfBottom, BS.empty]-  in mapM_ BS.putStrLn bs---- | Input key via the frontend.-nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier)-nextEvent sess mb = do-  e <- BS.hGet SIO.stdin 1-  let c = BS.head e-  if c == '\n'  -- let \n mark the end of input, for human players-    then nextEvent sess mb-    else return (keyTranslate c, K.NoModifier)---- | Display a prompt, wait for any key.-promptGetAnyKey :: FrontendSession -> SingleFrame-             -> IO (K.Key, K.Modifier)-promptGetAnyKey sess frame = do-  display sess True True $ Just frame-  nextEvent sess Nothing---- HACK: Special translation that block commands the bots should not use--- and multiplies some other commands.-keyTranslate :: Char -> K.Key-keyTranslate e =-  case e of-    -- Translate some special keys (use vi keys to move).-    '\ESC' -> K.Esc-    '\n'   -> K.Return-    '\r'   -> K.Return-    '\t'   -> K.Tab-    --  For bots: disable purely UI commands.-    'P'    -> K.Char 'U'-    'V'    -> K.Char 'Y'-    'O'    -> K.Char 'J'-    'I'    -> K.Char 'L'-    'R'    -> K.Char 'K'-    '?'    -> K.Char 'N'-    -- For bots: don't let them give up, write files, procrastinate.-    'Q'    -> K.Char 'H'-    'X'    -> K.Char 'B'-    'D'    -> K.Return-    '.'    -> K.Return-    -- For bots (assuming they go from '0' to 'z'): major commands.-    '<'    -> K.Char 'q'  -- ban ascending to speed up descending-    '>'    -> K.Char '>'-    'c'    -> K.Char 'c'-    'd'    -> K.Char 'r'  -- don't let bots drop stuff-    'g'    -> K.Char 'g'-    'i'    -> K.Char 'i'-    'o'    -> K.Char 'o'-    'q'    -> K.Char 'q'-    'r'    -> K.Char 'r'-    't'    -> K.Char 'g'  -- tagetting is too hard, so don't throw-    'z'    -> K.Char 'g'  -- and don't zap-    'p'    -> K.Char 'g'  -- and don't project-    'a'    -> K.Esc       -- and don't apply-    -- For bots: minor commands. Targeting is too hard, so don't do it.-    '*'    -> K.Char 'c'-    '/'    -> K.Char 'c'-    '['    -> K.Char 'g'-    ']'    -> K.Char 'g'-    '{'    -> K.Char 'g'-    '}'    -> K.Char 'g'-    -- Hack for bots: dump config at the start.-    ' '    -> K.Char 'D'-    -- Movement and hero selection.-    c | c `elem` "kjhlyubnKJHLYUBN" -> K.Char c-    c | c `elem` ['0'..'9'] -> K.Char c-    _      -> K.Char '>'  -- try hard to descend

@@ -1,128 +0,0 @@--- | Text frontend based on Vty.-module Game.LambdaHack.Action.Frontend.Vty-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , display, nextEvent, promptGetAnyKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Graphics.Vty-import qualified Graphics.Vty as Vty-import qualified Data.List as L-import Data.Text.Encoding (encodeUtf8)--import qualified Game.LambdaHack.Key as K (Key(..), Modifier(..))-import qualified Game.LambdaHack.Color as Color-import Game.LambdaHack.Animation (SingleFrame(..))---- | Session data maintained by the frontend.-type FrontendSession = Vty---- | The name of the frontend.-frontendName :: String-frontendName = "vty"---- | Starts the main program loop using the frontend input and output.-startup :: String -> (FrontendSession -> IO ()) -> IO ()-startup _ k = do-  fs <- mkVty-  k fs-  Vty.shutdown fs---- | Output to the screen via the frontend.-display :: FrontendSession          -- ^ frontend session data-        -> Bool-        -> Bool-        -> Maybe SingleFrame  -- ^ the screen frame to draw-        -> IO ()-display _ _ _ Nothing = return ()-display vty _ _ (Just SingleFrame{..}) =-  let img = (foldr (<->) empty_image-             . L.map (foldr (<|>) empty_image-                      . L.map (\ Color.AttrChar{..} ->-                                char (setAttr acAttr) acChar)))-            sfLevel-      pic = pic_for_image $-              utf8_bytestring (setAttr Color.defaultAttr) (encodeUtf8 sfTop)-              <-> img <->-              utf8_bytestring (setAttr Color.defaultAttr) (encodeUtf8 sfBottom)-  in update vty pic---- | Input key via the frontend.-nextEvent :: FrontendSession -> Maybe Bool -> IO (K.Key, K.Modifier)-nextEvent sess mb = do-  e <- next_event sess-  case e of-    EvKey n mods -> do-      let key = keyTranslate n-          modifier = modifierTranslate mods-      return (key, modifier)-    _ -> nextEvent sess mb---- | Display a prompt, wait for any key.-promptGetAnyKey :: FrontendSession -> SingleFrame-             -> IO (K.Key, K.Modifier)-promptGetAnyKey sess frame = do-  display sess True True $ Just frame-  nextEvent sess Nothing--keyTranslate :: Key -> K.Key-keyTranslate n =-  case n of-    KEsc          -> K.Esc-    KEnter        -> K.Return-    (KASCII ' ')  -> K.Space-    (KASCII '\t') -> K.Tab-    KBackTab      -> K.BackTab-    KUp           -> K.Up-    KDown         -> K.Down-    KLeft         -> K.Left-    KRight        -> K.Right-    KHome         -> K.Home-    KPageUp       -> K.PgUp-    KEnd          -> K.End-    KPageDown     -> K.PgDn-    KBegin        -> K.Begin-    (KASCII c)    -> K.Char c-    _             -> K.Unknown (show n)---- | Translates modifiers to our own encoding.-modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods =-  if MCtrl `elem` mods then K.Control else K.NoModifier---- 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.-hack :: Color.Color -> Attr -> Attr-hack c a = if Color.isBright c then with_style a bold else a--setAttr :: Color.Attr -> Attr-setAttr Color.Attr{fg, bg} =--- This optimization breaks display for white background terminals:---  if (fg, bg) == Color.defaultAttr---  then def_attr---  else-  hack fg $ hack bg $-    def_attr { attr_fore_color = SetTo (aToc fg)-             , attr_back_color = SetTo (aToc bg) }--aToc :: Color.Color -> Color-aToc Color.Black     = black-aToc Color.Red       = red-aToc Color.Green     = green-aToc Color.Brown     = yellow-aToc Color.Blue      = blue-aToc Color.Magenta   = magenta-aToc Color.Cyan      = cyan-aToc Color.White     = white-aToc Color.BrBlack   = bright_black-aToc Color.BrRed     = bright_red-aToc Color.BrGreen   = bright_green-aToc Color.BrYellow  = bright_yellow-aToc Color.BrBlue    = bright_blue-aToc Color.BrMagenta = bright_magenta-aToc Color.BrCyan    = bright_cyan-aToc Color.BrWhite   = bright_white

@@ -1,152 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | High score table operations.-module Game.LambdaHack.Action.HighScore-  ( register-  ) where--import System.Directory-import Control.Monad-import Text.Printf-import System.Time-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--import Game.LambdaHack.Utils.File-import Game.LambdaHack.Config-import Game.LambdaHack.Dungeon-import Game.LambdaHack.Misc-import Game.LambdaHack.Time-import Game.LambdaHack.Msg-import Game.LambdaHack.State---- | 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-  }-  deriving (Eq, Ord)--instance Binary ScoreRecord where-  put (ScoreRecord p n (TOD cs cp) s) = do-    put p-    put n-    put cs-    put cp-    put s-  get = do-    p <- get-    n <- get-    cs <- get-    cp <- get-    s <- get-    return (ScoreRecord p n (TOD cs cp) s)---- | Show a single high score, from the given ranking in the high score table.-showScore :: (Int, ScoreRecord) -> [Text]-showScore (pos, score) =-  let died = case status score of-        Killed lvl -> "perished on level " ++ show (levelNumber lvl) ++ ","-        Camping -> "is camping somewhere,"-        Victor -> "emerged victorious"-        Restart -> "resigned prematurely"-      curDate = calendarTimeToString . toUTCTime . date $ score-      big, lil :: String-      big = "                                                 "-      lil = "              "-      turns = - (negTime score `timeFit` timeTurn)-     -- 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-       ]---- | The list of scores, in decreasing order.-type ScoreTable = [ScoreRecord]---- | Empty score table-empty :: ScoreTable-empty = []---- | Save a simple serialized version of the high scores table.-save :: ConfigUI -> ScoreTable -> IO ()-save ConfigUI{configScoresFile} scores = encodeEOF configScoresFile scores---- | Read the high scores table. Return the empty table if no file.-restore :: ConfigUI -> IO ScoreTable-restore ConfigUI{configScoresFile} = do-  b <- doesFileExist configScoresFile-  if not b-    then return empty-    else strictDecodeEOF configScoresFile---- | Insert a new score into the table, Return new table and the ranking.-insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)-insertPos s h =-  let (prefix, suffix) = L.span (> s) h-  in (prefix ++ [s] ++ suffix, L.length prefix + 1)---- | 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 h start height =-  let zipped    = zip [1..] h-      screenful = take height . drop (start - 1) $ zipped-  in concatMap showScore screenful---- | Produce a couple of renderings of the high scores table.-slideshow :: Int -> ScoreTable -> Int -> [Overlay]-slideshow 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]---- | Take care of saving a new score to the table--- and return a list of messages to display.-register :: ConfigUI   -- ^ the config file-         -> Bool       -- ^ whether to write or only render-         -> Int        -- ^ the total score. not halved yet-         -> Time       -- ^ game time spent-         -> ClockTime  -- ^ date of the last game interruption-         -> Status     -- ^ reason of the game interruption-         -> IO (Msg, [Overlay])-register configUI write total time date status = do-  h <- restore configUI-  let points = case status of-                 Killed _ -> (total + 1) `div` 2-                 _        -> total-      negTime = timeNegate time-      score = ScoreRecord{..}-      (h', pos) = insertPos score h-      (_, nlines) = normalLevelBound  -- TODO: query terminal size instead-      height = nlines `div` 3-      (subject, person, msgUnless) =-        case status of-          Killed lvl | levelNumber lvl <= 1 ->-            ("your short-lived struggle", MU.Sg3rd, "(score halved)")-          Killed _ ->-            ("your heroic deeds", MU.PlEtc, "(score halved)")-          Camping ->-            ("your valiant exploits", MU.PlEtc, "(unless you are slain)")-          Victor ->-            ("your glorious victory", MU.Sg3rd,-             if pos <= height-             then "among the greatest heroes"-             else "")-          Restart ->-            ("your abortive attempt", MU.Sg3rd, "(score halved)")-      msg = makeSentence-        [ MU.SubjectVerb person MU.Yes subject "award you"-        , MU.Ordinal pos, "place"-        , msgUnless ]-  when write $ save configUI h'-  return (msg, slideshow pos h' height)

@@ -1,143 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Saving and restoring games and player diaries.-module Game.LambdaHack.Action.Save-  ( saveGameFile, restoreGame, rmBkpSaveDiary, saveGameBkp-  ) where--import System.Directory-import System.FilePath-import qualified Control.Exception as Ex hiding (handle)-import Control.Monad-import Control.Concurrent-import System.IO.Unsafe (unsafePerformIO)  -- horrors-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Utils.File-import Game.LambdaHack.State-import Game.LambdaHack.Msg-import Game.LambdaHack.Config---- | Save a simple serialized version of the current player diary.-saveDiary :: FilePath -> Diary -> IO ()-saveDiary configDiaryFile diary = encodeEOF configDiaryFile diary--saveLock :: MVar ()-{-# NOINLINE saveLock #-}-saveLock = unsafePerformIO newEmptyMVar---- | Save a simple serialized version of the current state.--- Protected by a lock to avoid corrupting the file.-saveGameFile :: ConfigUI -> State -> IO ()-saveGameFile ConfigUI{configSaveFile} state = do-  putMVar saveLock ()-  encodeEOF configSaveFile state-  takeMVar saveLock---- | Try to create a directory. Hide errors due to,--- e.g., insufficient permissions, because the game can run--- in the current directory just as well.-tryCreateDir :: FilePath -> IO ()-tryCreateDir dir =-  Ex.catch-    (createDirectory dir)-    (\ e -> case e :: Ex.IOException of _ -> return ())---- | Try to copy over data files. Hide errors due to,--- e.g., insufficient permissions, because the game can run--- without data files just as well.-tryCopyDataFiles :: ConfigUI -> (FilePath -> IO FilePath) -> IO ()-tryCopyDataFiles ConfigUI{ configScoresFile-                         , configRulesCfgFile-                         , configUICfgFile } pathsDataFile = do-  rulesFile  <- pathsDataFile $ takeFileName configRulesCfgFile <.> ".default"-  uiFile     <- pathsDataFile $ takeFileName configUICfgFile    <.> ".default"-  scoresFile <- pathsDataFile $ takeFileName configScoresFile-  let newRulesFile  = configRulesCfgFile <.> ".ini"-      newUIFile     = configUICfgFile    <.> ".ini"-      newScoresFile = configScoresFile-  Ex.catch-    (copyFile rulesFile newRulesFile >>-     copyFile uiFile newUIFile >>-     copyFile scoresFile newScoresFile)-    (\ e -> case e :: Ex.IOException of _ -> return ())---- | Restore a saved game, if it exists. Initialize directory structure,--- if needed.-restoreGame :: ConfigUI -> (FilePath -> IO FilePath) -> Text-            -> IO (Either (State, Diary, Msg) (Diary, Msg))-restoreGame config@ConfigUI{ configAppDataDir-                           , configDiaryFile-                           , configSaveFile-                           , configBkpFile } pathsDataFile title = do-  ab <- doesDirectoryExist configAppDataDir-  -- If the directory can't be created, the current directory will be used.-  unless ab $ do-    tryCreateDir configAppDataDir-    -- Possibly copy over data files. No problem if it fails.-    tryCopyDataFiles config pathsDataFile-  -- If the diary file does not exist, create an empty diary.-  -- TODO: when diary gets corrupted, start a new one, too.-  diary <--    do db <- doesFileExist configDiaryFile-       if db-         then strictDecodeEOF configDiaryFile-         else defaultDiary-  -- If the savefile exists but we get IO errors, we show them,-  -- back up the savefile and move it out of the way and start a new game.-  -- If the savefile was randomly corrupted or made read-only,-  -- that should solve the problem. If the problems are more serious,-  -- the other functions will most probably also throw exceptions,-  -- this time without trying to fix it up.-  sb <- doesFileExist configSaveFile-  bb <- doesFileExist configBkpFile-  Ex.catch-    (if sb-       then do-         renameFile configSaveFile configBkpFile-         state <- strictDecodeEOF configBkpFile-         let msg = "Welcome back to" <+> title <> "."-         return $ Left (state, diary, msg)-       else-         if bb-           then do-             state <- strictDecodeEOF configBkpFile-             let msg = "No savefile found. Restoring from a backup savefile."-             return $ Left (state, diary, msg)-           else return $ Right (diary, "Welcome to" <+> title <> "!"))-    (\ e -> case e :: Ex.SomeException of-              _ -> let msg = "Starting a new game, because restore failed."-                             <+> "The error message was:"-                             <+> (T.unwords . T.lines) (showT e)-                   in return $ Right (diary, msg))---- | Save the diary and a backup of the save game file, in case of crashes.--- This is only a backup, so no problem is the game is shut down--- before saving finishes, so we don't wait on the mvar. However,--- if a previous save is already in progress, we skip this save.-saveGameBkp :: ConfigUI -> State -> Diary -> IO ()-saveGameBkp ConfigUI{ configDiaryFile-                    , configSaveFile-                    , configBkpFile } state diary = do-  b <- tryPutMVar saveLock ()-  when b $-    void $ forkIO $ do-      saveDiary configDiaryFile diary  -- save diary often in case of crashes-      encodeEOF configSaveFile state-      renameFile configSaveFile configBkpFile-      takeMVar saveLock---- | Remove the backup of the savegame and save the player diary.--- Should be called before any non-error exit from the game.--- Sometimes the backup file does not exist and it's OK.--- We don't bother reporting any other removal exceptions, either,--- because the backup file is relatively unimportant.--- We wait on the mvar, because saving the diary at game shutdown is important.-rmBkpSaveDiary :: ConfigUI -> Diary -> IO ()-rmBkpSaveDiary ConfigUI{ configDiaryFile-                       , configBkpFile } diary = do-  putMVar saveLock ()-  saveDiary configDiaryFile diary  -- save diary often in case of crashes-  bb <- doesFileExist configBkpFile-  when bb $ removeFile configBkpFile-  takeMVar saveLock

@@ -1,644 +0,0 @@-{-# LANGUAGE OverloadedStrings, ExtendedDefaultRules #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}--- | The game action stuff that is independent from ItemAction.hs--- (both depend on EffectAction.hs).--- TODO: Add an export list and document after it's rewritten according to #17.-module Game.LambdaHack.Actions where---- Cabal-import qualified Paths_LambdaHack as Self (version)--import Control.Monad-import Control.Monad.State hiding (State, state)-import qualified Data.List as L-import qualified Data.IntMap as IM-import qualified Data.Map as M-import Data.Maybe-import Data.Version-import qualified Data.IntSet as IS-import Data.Ratio-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.Action-import Game.LambdaHack.Point-import Game.LambdaHack.Vector-import qualified Game.LambdaHack.Dungeon as Dungeon-import Game.LambdaHack.Item-import qualified Game.LambdaHack.Key as K-import Game.LambdaHack.Level-import Game.LambdaHack.Actor-import Game.LambdaHack.ActorState-import Game.LambdaHack.Perception-import Game.LambdaHack.State-import qualified Game.LambdaHack.Effect as Effect-import Game.LambdaHack.EffectAction-import qualified Game.LambdaHack.Tile as Tile-import qualified Game.LambdaHack.Kind as Kind-import qualified Game.LambdaHack.Feature as F-import Game.LambdaHack.DungeonState-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.TileKind as TileKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Random-import Game.LambdaHack.Misc-import Game.LambdaHack.Msg-import Game.LambdaHack.Binding-import Game.LambdaHack.Time-import Game.LambdaHack.Animation (swapPlaces, blockMiss)-import Game.LambdaHack.Draw-import qualified Game.LambdaHack.Command as Command-import Game.LambdaHack.Config--default (Text)--gameSave :: Action ()-gameSave = do-  saveGameBkp-  msgAdd "Game progress saved to a backup file."--gameExit :: Action ()-gameExit = do-  b <- displayYesNo "Really save and exit?"-  if b-    then modify (\ s -> s {squit = Just (True, Camping)})-    else abortWith "Game resumed."--gameRestart :: Action ()-gameRestart = do-  b1 <- displayMore ColorFull "You just requested a new game."-  when (not b1) $ neverMind True-  b2 <- displayYesNo "Current progress will be lost! Really restart the game?"-  when (not b2) $ abortWith "Yea, so much still to do."-  modify (\ s -> s {squit = Just (False, Restart)})--moveCursor :: Vector -> Int -> ActionFrame ()-moveCursor dir n = do-  lxsize <- gets (lxsize . slevel)-  lysize <- gets (lysize . slevel)-  let upd cursor =-        let shiftB loc =-              shiftBounded lxsize (1, 1, lxsize - 2, lysize - 2) loc dir-            cloc = iterate shiftB (clocation cursor) !! n-        in cursor { clocation = cloc }-  modify (updateCursor upd)-  doLook---- TODO: Think about doing the mode dispatch elsewhere, especially if over--- time more and more commands need to do the dispatch inside their code--- (currently only a couple do).-move :: Vector -> ActionFrame ()-move dir = do-  pl <- gets splayer-  targeting <- gets (ctargeting . scursor)-  if targeting /= TgtOff-    then do-      frs <- moveCursor dir 1-      -- Mark that unexpectedly it does not take time.-      modify (\ s -> s {stakeTime = Just False})-      return frs-    else-      inFrame $ moveOrAttack True pl dir--ifRunning :: ((Vector, Int) -> Action a) -> Action a -> Action a-ifRunning t e = do-  ad <- gets (bdir . getPlayerBody)-  maybe e t ad---- | Guess and report why the bump command failed.-guessBump :: Kind.Ops TileKind -> F.Feature -> Kind.Id TileKind -> Action ()-guessBump cotile F.Openable t | Tile.hasFeature cotile F.Closable t =-  abortWith "already open"-guessBump _ F.Openable _ =-  abortWith "not a door"-guessBump cotile F.Closable t | Tile.hasFeature cotile F.Openable t =-  abortWith "already closed"-guessBump _ F.Closable _ =-  abortWith "not a door"-guessBump cotile F.Ascendable t | Tile.hasFeature cotile F.Descendable t =-  abortWith "the way goes down, not up"-guessBump _ F.Ascendable _ =-  abortWith "no stairs up"-guessBump cotile F.Descendable t | Tile.hasFeature cotile F.Ascendable t =-  abortWith "the way goes up, not down"-guessBump _ F.Descendable _ =-  abortWith "no stairs down"-guessBump _ _ _ = neverMind True---- | Player tries to trigger a tile using a feature.-bumpTile :: Point -> F.Feature -> Action ()-bumpTile dloc feat = do-  Kind.COps{cotile} <- getCOps-  lvl    <- gets slevel-  let t = lvl `at` dloc-  if Tile.hasFeature cotile feat t-    then triggerTile dloc-    else guessBump cotile feat t---- | Perform the action specified for the tile in case it's triggered.-triggerTile :: Point -> Action ()-triggerTile dloc = do-  Kind.COps{cotile=Kind.Ops{okind, opick}} <- getCOps-  lvl <- gets slevel-  let f (F.Cause effect) = do-        pl <- gets splayer-        void $ effectToAction effect 0 pl pl 0 False  -- no block against tile-        return ()-      f (F.ChangeTo group) = do-        Level{lactor} <- gets slevel-        case lvl `atI` dloc of-          [] -> if unoccupied (IM.elems lactor) dloc-                then do-                  newTileId <- rndToAction $ opick group (const True)-                  let adj = (Kind.// [(dloc, newTileId)])-                  modify (updateLevel (updateLMap adj))--- TODO: take care of AI using this function (aborts, etc.).-                else abortWith "blocked"  -- by monsters or heroes-          _ : _ -> abortWith "jammed"  -- by items-      f _ = return ()-  mapM_ f $ TileKind.tfeature $ okind $ lvl `at` dloc---- | Ask for a direction and trigger a tile, if possible.-playerTriggerDir :: F.Feature -> MU.Part -> Action ()-playerTriggerDir feat verb = do-  let keys = zip K.dirAllMoveKey $ repeat K.NoModifier-      prompt = makePhrase ["What to", verb MU.:> "? [movement key"]-  e <- displayChoiceUI prompt [] keys-  lxsize <- gets (lxsize . slevel)-  K.handleDir lxsize e (playerBumpDir feat) (neverMind True)---- | Player tries to trigger a tile in a given direction.-playerBumpDir :: F.Feature -> Vector -> Action ()-playerBumpDir feat dir = do-  pl    <- gets splayer-  body  <- gets (getActor pl)-  let dloc = bloc body `shift` dir-  bumpTile dloc feat---- | Player tries to trigger the tile he's standing on.-playerTriggerTile :: F.Feature -> Action ()-playerTriggerTile feat = do-  ploc <- gets (bloc . getPlayerBody)-  bumpTile ploc feat---- | An actor opens a door: player (hero or controlled monster) or enemy.-actorOpenDoor :: ActorId -> Vector -> Action ()-actorOpenDoor actor dir = do-  Kind.COps{ cotile-           , coitem-           , coactor=Kind.Ops{okind}-           } <- getCOps-  lvl  <- gets slevel-  pl   <- gets splayer-  body <- gets (getActor actor)-  bitems <- gets (getActorItem actor)-  let dloc = shift (bloc body) dir  -- the location we act upon-      t = lvl `at` dloc-      isPlayer = actor == pl-      isVerbose = isPlayer  -- don't report, unless it's player-controlled-      iq = aiq $ okind $ bkind body-      openPower = timeScale timeTurn $-        if isPlayer-        then 0  -- player can't open hidden doors-        else case strongestSearch coitem bitems of-               Just i  -> iq + jpower i-               Nothing -> iq-  unless (openable cotile lvl openPower dloc) $ neverMind isVerbose-  if Tile.hasFeature cotile F.Closable t-    then abortIfWith isVerbose "already open"-    else if not (Tile.hasFeature cotile F.Closable t ||-                 Tile.hasFeature cotile F.Openable t ||-                 Tile.hasFeature cotile F.Hidden t)-         then neverMind isVerbose  -- not doors at all-         else triggerTile dloc---- | Change the displayed level in targeting mode to (at most)--- k levels shallower. Enters targeting mode, if not already in one.-tgtAscend :: Int -> ActionFrame ()-tgtAscend k = do-  Kind.COps{cotile} <- getCOps-  cursor    <- gets scursor-  targeting <- gets (ctargeting . scursor)-  slid      <- gets slid-  lvl       <- gets slevel-  st        <- get-  dungeon   <- gets sdungeon-  let loc = clocation cursor-      tile = lvl `at` loc-      rightStairs =-        k ==  1 && Tile.hasFeature cotile (F.Cause Effect.Ascend)  tile ||-        k == -1 && Tile.hasFeature cotile (F.Cause Effect.Descend) tile-  if rightStairs  -- stairs, in the right direction-    then case whereTo st k of-      Nothing ->  -- we are at the "end" of the dungeon-        abortWith "no more levels in this direction"-      Just (nln, nloc) ->-        assert (nln /= slid `blame` (nln, "stairs looped")) $ do-          -- We only look at the level, but we have to keep current-          -- time somewhere, e.g., for when we change the player-          -- to a hero on this level and then end targeting.-          -- If that's too slow, we could keep current time in the @Cursor@.-          switchLevel nln-          -- do not freely reveal the other end of the stairs-          lvl2 <- gets slevel-          let upd cur =-                let clocation =-                      if Tile.hasFeature cotile F.Exit (lvl2 `rememberAt` nloc)-                      then nloc  -- already know as an exit, focus on it-                      else loc   -- unknow, do not reveal the position-                in cur { clocation, clocLn = nln }-          modify (updateCursor upd)-    else do  -- no stairs in the right direction-      let n = Dungeon.levelNumber slid-          depth = Dungeon.depth dungeon-          nln = Dungeon.levelDefault $ min depth $ max 1 $ n - k-      when (nln == slid) $ abortWith "no more levels in this direction"-      switchLevel nln  -- see comment above-      let upd cur = cur {clocLn = nln}-      modify (updateCursor upd)-  when (targeting == TgtOff) $ do-    let upd cur = cur {ctargeting = TgtExplicit}-    modify (updateCursor upd)-  doLook--heroesAfterPl :: Action [ActorId]-heroesAfterPl = do-  pl <- gets splayer-  s  <- get-  let hs = map (tryFindHeroK s) [0..9]-      i = fromMaybe (-1) $ L.findIndex (== Just pl) hs-      (lt, gt) = (take i hs, drop (i + 1) hs)-  return $ catMaybes gt ++ catMaybes lt---- | Switches current hero to the next hero on the level, if any, wrapping.--- We cycle through at most 10 heroes (\@, 1--9).-cycleHero :: Action ()-cycleHero = do-  pl <- gets splayer-  s  <- get-  hs <- heroesAfterPl-  case L.filter (flip memActor s) hs of-    [] -> abortWith "Cannot select any other hero on this level."-    ni : _ -> selectPlayer ni-                >>= assert `trueM` (pl, ni, "hero duplicated")---- | Switches current hero to the previous hero in the whole dungeon,--- if any, wrapping. We cycle through at most 10 heroes (\@, 1--9).-backCycleHero :: Action ()-backCycleHero = do-  pl <- gets splayer-  hs <- heroesAfterPl-  case reverse hs of-    [] -> abortWith "No other hero in the party."-    ni : _ -> selectPlayer ni-                >>= assert `trueM` (pl, ni, "hero duplicated")---- | Search for hidden doors.-search :: Action ()-search = do-  Kind.COps{coitem, cotile} <- getCOps-  lvl    <- gets slevel-  le     <- gets (lsecret . slevel)-  lxsize <- gets (lxsize . slevel)-  ploc   <- gets (bloc . getPlayerBody)-  pitems <- gets getPlayerItem-  let delta = timeScale timeTurn $-                case strongestSearch coitem pitems of-                  Just i  -> 1 + jpower i-                  Nothing -> 1-      searchTile sle mv =-        let loc = shift ploc mv-            t = lvl `at` loc-            -- TODO: assert or cope elsewhere with the IM.! below-            k = timeAdd (le IM.! loc) $ timeNegate delta-        in if Tile.hasFeature cotile F.Hidden t-           then if k > timeZero-                then IM.insert loc k sle-                else IM.delete loc sle-           else sle-      leNew = L.foldl' searchTile le (moves lxsize)-  modify (updateLevel (\ l -> l {lsecret = leNew}))-  lvlNew <- gets slevel-  let triggerHidden mv = do-        let dloc = shift ploc mv-            t = lvlNew `at` dloc-        when (Tile.hasFeature cotile F.Hidden t && IM.notMember dloc leNew) $-          triggerTile dloc-  mapM_ triggerHidden (moves lxsize)---- | This function performs a move (or attack) by any actor,--- i.e., it can handle monsters, heroes and both.-moveOrAttack :: Bool       -- ^ allow attacks?-             -> ActorId    -- ^ who's moving?-             -> Vector     -- ^ in which direction?-             -> Action ()-moveOrAttack allowAttacks actor dir = do-  -- We start by looking at the target position.-  cops@Kind.COps{cotile = cotile@Kind.Ops{okind}} <- getCOps-  state  <- get-  pl     <- gets splayer-  lvl    <- gets slevel-  sm     <- gets (getActor actor)-  let sloc = bloc sm           -- source location-      tloc = sloc `shift` dir  -- target location-  tgt <- gets (locToActor tloc)-  case tgt of-    Just target-      | allowAttacks ->-          -- Attacking does not require full access, adjacency is enough.-          actorAttackActor actor target-      | accessible cops lvl sloc tloc -> do-          -- Switching positions requires full access.-          when (actor == pl) $-            msgAdd $ lookAt cops False True state lvl tloc ""-          actorRunActor actor target-      | otherwise -> abortWith "blocked"-    Nothing-      | accessible cops lvl sloc tloc -> do-          -- Perform the move.-          updateAnyActor actor $ \ body -> body {bloc = tloc}-          when (actor == pl) $-            msgAdd $ lookAt cops False True state lvl tloc ""-      | allowAttacks && actor == pl-        && Tile.canBeHidden cotile (okind $ lvl `rememberAt` tloc) -> do-          msgAdd "You search all adjacent walls for half a second."-          search-      | otherwise ->-          actorOpenDoor actor dir  -- try to open a door, TODO: bumpTile tloc F.Openable---- | Resolves the result of an actor moving into another. Usually this--- involves melee attack, but with two heroes it just changes focus.--- Actors on blocked locations can be attacked without any restrictions.--- For instance, an actor embedded in a wall--- can be attacked from an adjacent position.--- This function is analogous to projectGroupItem, but for melee--- and not using up the weapon.-actorAttackActor :: ActorId -> ActorId -> Action ()-actorAttackActor source target = do-  smRaw <- gets (getActor source)-  tmRaw <- gets (getActor target)-  per   <- getPerception-  time  <- gets stime-  sfaction <- gets sfaction-  let sloc = bloc smRaw-      tloc = bloc tmRaw-      svisible = sloc `IS.member` totalVisible per-      tvisible = tloc `IS.member` totalVisible per-      sm | svisible  = smRaw-         | otherwise = smRaw {bname = Just "somebody"}-      tm | tvisible  = tmRaw-         | otherwise = tmRaw {bname = Just "somebody"}-  if bfaction sm == sfaction && not (bproj sm) &&-     bfaction tm == sfaction && not (bproj tm)-    then do-      -- Select adjacent hero by bumping into him. Takes no time, so rewind.-      selectPlayer target-        >>= assert `trueM` (source, target, "heroes attack each other")-      -- Mark that unexpectedly it does not take time.-      modify (\ s -> s {stakeTime = Just False})-    else do-      cops@Kind.COps{coactor, coitem=coitem@Kind.Ops{opick, okind}} <- getCOps-      state <- get-      bitems <- gets (getActorItem source)-      let h2hGroup = if isAHero state source then "unarmed" else "monstrous"-      h2hKind <- rndToAction $ opick h2hGroup (const True)-      let h2hItem = Item h2hKind 0 Nothing 1-          (stack, tell, verbosity, verb) =-            if isProjectile state source-            then case bitems of-              [bitem] -> (bitem, False, 10, "hit")       -- projectile-              _ -> assert `failure` bitems-            else case strongestSword cops bitems of-              Nothing -> (h2hItem, False, 0,-                          iverbApply $ okind $ h2hKind)  -- hand to hand combat-              Just w  -> (w, True, 0,-                          iverbApply $ okind $ jkind w)  -- weapon-          -- The msg describes the source part of the action.-          -- TODO: right now it also describes the victim and weapon;-          -- perhaps, when a weapon is equipped, just say "you hit"-          -- or "you miss" and then "nose dies" or "nose yells in pain".-          msg = makeSentence $-            [ MU.SubjectVerbSg (partActor coactor sm) verb-            , partActor coactor tm ]-            ++ if tell-               then ["with", MU.AW $ partItem coitem state stack]-               else []-          msgMiss = makeSentence-            [ MU.SubjectVerbSg (partActor coactor sm) "try to"-            , verb MU.:> ", but"-            , MU.SubjectVerbSg (partActor coactor tm) "block"-            ]-      let performHit block = do-            when (svisible || tvisible) $ msgAdd msg-            -- Msgs inside itemEffectAction describe the target part.-            itemEffectAction verbosity source target stack block-      -- Projectiles can't be blocked, can be sidestepped.-      if braced tm time && not (bproj sm)-        then do-          blocked <- rndToAction $ chance $ 1%2-          if blocked-            then do-              when (svisible || tvisible) $ msgAdd msgMiss-              diary <- getDiary-              let locs = (breturn tvisible tloc,-                          breturn svisible sloc)-                  anim = blockMiss locs-                  animFrs = animate state diary cops per anim-              mapM_ displayFramePush $ Nothing : animFrs-            else performHit True-        else performHit False---- | Resolves the result of an actor running (not walking) into another.--- This involves switching positions of the two actors.-actorRunActor :: ActorId -> ActorId -> Action ()-actorRunActor source target = do-  pl <- gets splayer-  sm <- gets (getActor source)-  tm <- gets (getActor target)-  let sloc = bloc sm-      tloc = bloc tm-  updateAnyActor source $ \ m -> m { bloc = tloc }-  updateAnyActor target $ \ m -> m { bloc = sloc }-  cops@Kind.COps{coactor} <- getCOps-  per <- getPerception-  let visible = sloc `IS.member` totalVisible per ||-                tloc `IS.member` totalVisible per-      msg = makeSentence-        [ MU.SubjectVerbSg (partActor coactor sm) "displace"-        , partActor coactor tm ]-  when visible $ msgAdd msg-  diary <- getDiary  -- here diary possibly contains the new msg-  s <- get-  let locs = (Just tloc, Just sloc)-      animFrs = animate s diary cops per $ swapPlaces locs-  when visible $ mapM_ displayFramePush $ Nothing : animFrs-  if source == pl-   then stopRunning  -- do not switch positions repeatedly-   else void $ focusIfOurs target---- | Create a new monster in the level, at a random position.-rollMonster :: Kind.COps -> Perception -> State -> Rnd State-rollMonster Kind.COps{ cotile-                     , coactor=Kind.Ops{opick, okind}-                     , cofact=Kind.Ops{opick=fopick, oname=foname}-                     } per state = do-  let lvl@Level{lactor} = slevel state-      ms = hostileList state-      hs = heroList state-      isLit = Tile.isLit cotile-  rc <- monsterGenChance (Dungeon.levelNumber $ slid state) (L.length ms)-  if not rc-    then return state-    else do-      let distantAtLeast d =-            \ l _ -> L.all (\ h -> chessDist (lxsize lvl) (bloc h) l > d) hs-      loc <--        findLocTry 20 (lmap lvl)  -- 20 only, for unpredictability-          [ \ _ t -> not (isLit t)-          , distantAtLeast 15-          , \ l t -> not (isLit t) || distantAtLeast 15 l t-          , distantAtLeast 10-          , \ l _ -> not $ l `IS.member` totalVisible per-          , distantAtLeast 5-          , \ l t -> Tile.hasFeature cotile F.Walkable t-                     && unoccupied (IM.elems lactor) l-          ]-      bfaction <- fopick "spawn" (const True)-      mk <- opick (foname bfaction) (const True)-      hp <- rollDice $ ahp $ okind mk-      return $ addMonster cotile mk hp loc bfaction False state---- | Generate a monster, possibly.-generateMonster :: Action ()-generateMonster = do-  cops    <- getCOps-  state   <- get-  per     <- getPerception-  nstate  <- rndToAction $ rollMonster cops per state-  srandom <- gets srandom-  put $ nstate {srandom}---- | Possibly regenerate HP for all actors on the current level.-regenerateLevelHP :: Action ()-regenerateLevelHP = do-  Kind.COps{ coitem-           , coactor=coactor@Kind.Ops{okind}-           } <- getCOps-  time <- gets stime-  let upd itemIM a m =-        let ak = okind $ bkind m-            bitems = fromMaybe [] $ IM.lookup a itemIM-            regen = max 1 $-                      aregen ak `div`-                      case strongestRegen coitem bitems of-                        Just i  -> 5 * jpower i-                        Nothing -> 1-        in if (time `timeFit` timeTurn) `mod` regen /= 0-           then m-           else addHp coactor 1 m-  -- We really want hero selection to be a purely UI distinction,-  -- so all heroes need to regenerate, not just the player.-  -- Only the heroes on the current level regenerate (others are frozen-  -- in time together with their level). This prevents cheating-  -- via sending one hero to a safe level and waiting there.-  hi <- gets (linv . slevel)-  modify (updateLevel (updateActorDict (IM.mapWithKey (upd hi))))---- | Display command help.-displayHelp :: ActionFrame ()-displayHelp = do-  keyb <- getBinding-  displayOverlays "Basic keys." "[press SPACE to advance]" $ keyHelp keyb---- | Display the main menu.-displayMainMenu :: ActionFrame ()-displayMainMenu = do-  Kind.COps{corule} <- getCOps-  Binding{krevMap} <- getBinding-  let stripFrame t = case T.uncons t of-        Just ('\n', art) -> map (T.tail . T.init) $ tail . init $ T.lines art-        _ -> assert `failure` "displayMainMenu:" <+> t-      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 key = (showT key, Command.cmdDescription cmd)-            revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd krevMap-            cmds = [Command.GameSave, Command.GameExit,-                   Command.GameRestart, Command.Help]-        in map revLookup cmds ++ [(fst (revLookup Command.Clear), "continue")]-      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 . L.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"-    hd : tl -> displayOverlays hd "" [tl]--displayHistory :: ActionFrame ()-displayHistory = do-  Diary{shistory} <- getDiary-  time <- gets stime-  lysize <- gets (lysize . slevel)-  let turn = time `timeFit` timeTurn-      msg = makeSentence [ "You survived for"-                       , MU.NWs turn "half-second turn" ]-            <+> "Past messages:"-  displayOverlays msg "" $-    splitOverlay lysize $ renderHistory shistory--dumpConfig :: Action ()-dumpConfig = do-  ConfigUI{configRulesCfgFile} <- getConfigUI-  let fn = configRulesCfgFile ++ ".dump"-      msg = "Current game rules configuration dumped to file"-            <+> T.pack fn <> "."-  dumpCfg fn-  abortWith msg---- | Add new smell traces to the level. Only humans leave a strong scent.-addSmell :: Action ()-addSmell = do-  s  <- get-  pl <- gets splayer-  let time = stime s-      ploc = bloc (getPlayerBody s)-      upd = IM.insert ploc $ timeAdd time $ smellTimeout s-  when (isAHero s pl) $-    modify $ updateLevel $ updateSmell upd---- | Update the wait/block count.-setWaitBlock :: ActorId -> Action ()-setWaitBlock actor = do-  Kind.COps{coactor} <- getCOps-  time <- gets stime-  updateAnyActor actor $ \ m -> m {bwait = timeAddFromSpeed coactor m time}---- | Player waits a turn (and blocks, etc.).-waitBlock :: Action ()-waitBlock = do-  pl <- gets splayer-  setWaitBlock pl

@@ -1,198 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Actors in the game: monsters and heroes. No operation in this module--- involves the 'State' or 'Action' type.-module Game.LambdaHack.Actor-  ( -- * Actor identifiers and related operations-    ActorId, findHeroName, monsterGenChance, partActor-    -- * The@ Acto@r type-  , Actor(..), template, addHp, timeAddFromSpeed, braced-  , unoccupied, heroKindId, projectileKindId, actorSpeed-    -- * Type of na actor target-  , Target(..)-  ) where--import Control.Monad-import Data.Binary-import Data.Maybe-import Data.Ratio-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.Vector-import Game.LambdaHack.Point-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.FactionKind-import qualified Game.LambdaHack.Kind as Kind-import Game.LambdaHack.Msg-import Game.LambdaHack.Random-import Game.LambdaHack.Config-import Game.LambdaHack.Time-import qualified Game.LambdaHack.Color as Color---- | Actor properties that are changing throughout the game.--- If they are dublets of properties from @ActorKind@,--- 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  :: !(Maybe Char)           -- ^ individual map symbol-  , bname    :: !(Maybe Text)           -- ^ individual name-  , bcolor   :: !(Maybe Color.Color)    -- ^ individual map color-  , bspeed   :: !(Maybe Speed)          -- ^ individual speed-  , bhp      :: !Int                    -- ^ current hit points-  , bdir     :: !(Maybe (Vector, Int))  -- ^ direction and distance of running-  , btarget  :: Target                  -- ^ target for ranged attacks and AI-  , bloc     :: !Point                  -- ^ current location-  , bletter  :: !Char                   -- ^ next inventory letter-  , btime    :: !Time                   -- ^ absolute time of next action-  , bwait    :: !Time                   -- ^ last bracing expires at this time-  , bfaction :: !(Kind.Id FactionKind)  -- ^ to which faction the actor belongs-  , bproj    :: !Bool                   -- ^ is a projectile? (shorthand only,-                                        -- ^ this can be deduced from bkind)-  }-  deriving Show--instance Binary Actor where-  put Actor{..} = do-    put bkind-    put bsymbol-    put bname-    put bcolor-    put bspeed-    put bhp-    put bdir-    put btarget-    put bloc-    put bletter-    put btime-    put bwait-    put bfaction-    put bproj-  get = do-    bkind   <- get-    bsymbol <- get-    bname   <- get-    bcolor  <- get-    bspeed  <- get-    bhp     <- get-    bdir    <- get-    btarget <- get-    bloc    <- get-    bletter <- get-    btime   <- get-    bwait   <- get-    bfaction <- get-    bproj    <- get-    return Actor{..}---- ActorId operations---- | A unique identifier of an actor in a dungeon.-type ActorId = Int---- | Find a hero name in the config file, or create a stock name.-findHeroName :: ConfigUI -> Int -> Text-findHeroName ConfigUI{configHeroNames} n =-  let heroName = lookup n configHeroNames-  in fromMaybe ("hero number" <+> showT n) heroName---- | Chance that a new monster is generated. Currently depends on the--- number of monsters already present, and on the level. In the future,--- the strength of the character and the strength of the monsters present--- could further influence the chance, and the chance could also affect--- which monster is generated. How many and which monsters are generated--- will also depend on the cave kind used to build the level.-monsterGenChance :: Int -> Int -> Rnd Bool-monsterGenChance depth numMonsters =-  chance $ 1%(fromIntegral (30 * (numMonsters - depth)) `max` 5)---- | The part of speech describing the actor.-partActor :: Kind.Ops ActorKind -> Actor -> MU.Part-partActor Kind.Ops{oname} a = MU.Text $ fromMaybe (oname $ bkind a) (bname a)---- Actor operations---- | A template for a new non-projectile actor. The initial target is invalid--- to force a reset ASAP.-template :: Kind.Id ActorKind -> Maybe Char -> Maybe Text -> Int -> Point-         -> Time -> Kind.Id FactionKind -> Bool -> Actor-template bkind bsymbol bname bhp bloc btime bfaction bproj =-  let bcolor  = Nothing-      bspeed  = Nothing-      btarget = invalidTarget-      bdir    = Nothing-      bletter = 'a'-      bwait   = timeZero-  in Actor{..}---- | Increment current hit points of an actor.-addHp :: Kind.Ops ActorKind -> Int -> Actor -> Actor-addHp Kind.Ops{okind} extra m =-  assert (extra >= 0 `blame` extra) $-  let maxHP = maxDice (ahp $ okind $ bkind m)-      currentHP = bhp m-  in if currentHP > maxHP-     then m-     else m {bhp = min maxHP (currentHP + extra)}---- | Access actor speed, individual or, otherwise, stock.-actorSpeed :: Kind.Ops ActorKind -> Actor -> Speed-actorSpeed Kind.Ops{okind} m =-  let stockSpeed = aspeed $ okind $ bkind m-  in fromMaybe stockSpeed $ bspeed m---- | Add time taken by a single step at the actor's current speed.-timeAddFromSpeed :: Kind.Ops ActorKind -> Actor -> Time -> Time-timeAddFromSpeed coactor m time =-  let speed = actorSpeed coactor m-      delta = ticksPerMeter speed-  in timeAdd time delta---- | Whether an actor is braced for combat this turn.-braced :: Actor -> Time -> Bool-braced m time = time < bwait m---- | Checks for the presence of actors in a location.--- Does not check if the tile is walkable.-unoccupied :: [Actor] -> Point -> Bool-unoccupied actors loc =-  all (\ body -> bloc body /= loc) actors---- | The unique kind of heroes.-heroKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind-heroKindId Kind.Ops{ouniqGroup} = ouniqGroup "hero"---- | The unique kind of projectiles.-projectileKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind-projectileKindId Kind.Ops{ouniqGroup} = ouniqGroup "projectile"---- Target---- | The type of na actor target.-data Target =-    TEnemy ActorId Point  -- ^ target an actor with its last seen location-  | TLoc Point            -- ^ target a given location-  | TPath [Vector]        -- ^ target the list of locations one after another-  | TCursor               -- ^ target current position of the cursor; default-  deriving (Show, Eq)---- | An invalid target, with an actor that is not on any level.-invalidTarget :: Target-invalidTarget =-  let invalidActorId = -1-  in TEnemy invalidActorId origin--instance Binary Target where-  put (TEnemy a ll) = putWord8 0 >> put a >> put ll-  put (TLoc loc) = putWord8 1 >> put loc-  put (TPath ls) = putWord8 2 >> put ls-  put TCursor    = putWord8 3-  get = do-    tag <- getWord8-    case tag of-      0 -> liftM2 TEnemy get get-      1 -> liftM TLoc get-      2 -> liftM TPath get-      3 -> return TCursor-      _ -> fail "no parse (Target)"

@@ -1,307 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Operations on the 'Actor' type that need the 'State' type,--- but not the 'Action' type.--- TODO: Document an export list after it's rewritten according to #17.-module Game.LambdaHack.ActorState-  ( isProjectile, isAHero, getPlayerBody, findActorAnyLevel, calculateTotal-  , smellTimeout, initialHeroes, deletePlayer, allHeroesAnyLevel-  , locToActor, deleteActor, addHero, addMonster, updateAnyActorItem-  , insertActor, heroList, memActor, getActor, updateAnyActorBody-  , hostileList, getActorItem, getPlayerItem, tryFindHeroK, dangerousList-  , factionList, addProjectile, foesAdjacent, targetToLoc, hostileAssocs-  ) where--import Control.Monad-import qualified Data.List as L-import qualified Data.IntSet as IS-import qualified Data.IntMap as IM-import Data.Maybe-import qualified Data.Char as Char-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.Point-import Game.LambdaHack.PointXY-import Game.LambdaHack.Vector-import Game.LambdaHack.Actor-import Game.LambdaHack.Level-import Game.LambdaHack.Dungeon-import Game.LambdaHack.State-import Game.LambdaHack.Msg-import Game.LambdaHack.Item-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Config-import qualified Game.LambdaHack.Tile as Tile-import qualified Game.LambdaHack.Kind as Kind-import qualified Game.LambdaHack.Feature as F-import Game.LambdaHack.Time---- | Checks whether an actor identifier represents a hero.-isProjectile :: State -> ActorId -> Bool-isProjectile s a =-  let (_, actor, _) = findActorAnyLevel a s-  in bproj actor---- TODO: currently it's false for player-controlled monsters.--- When it's no longer, rewrite the places where it matters.--- | Checks whether an actor identifier represents a hero.-isAHero :: State -> ActorId -> Bool-isAHero s a =-  let (_, actor, _) = findActorAnyLevel a s-  in bfaction actor == sfaction s && not (bproj actor)---- TODO: move to TileState if ever created.--- | How long until an actor's smell vanishes from a tile.-smellTimeout :: State -> Time-smellTimeout s =-  let Config{configSmellTimeout} = sconfig s-  in timeScale timeTurn configSmellTimeout---- The operations with "Any", and those that use them,--- consider all the dungeon.--- All the other actor and level operations only consider the current level.---- | Finds an actor body on any level. Fails if not found.-findActorAnyLevel :: ActorId -> State -> (LevelId, Actor, [Item])-findActorAnyLevel actor State{slid, sdungeon} =-  let chk (ln, lvl) =-        let (m, mi) = (IM.lookup actor (lactor lvl),-                       IM.lookup actor (linv lvl))-        in fmap (\ a -> (ln, a, fromMaybe [] mi)) m-  in case mapMaybe chk (currentFirst slid sdungeon) of-    []      -> assert `failure` actor-    res : _ -> res  -- checking if res is unique would break laziness---- | Tries to finds an actor body satisfying a predicate on any level.-tryFindActor :: State -> (Actor -> Bool) -> Maybe (ActorId, Actor)-tryFindActor State{slid, sdungeon} p =-  let chk (_ln, lvl) = L.find (p . snd) $ IM.assocs $ lactor lvl-  in case mapMaybe chk (currentFirst slid sdungeon) of-    []      -> Nothing-    res : _ -> Just res--getPlayerBody :: State -> Actor-getPlayerBody s@State{splayer} =-  let (_, actor, _) = findActorAnyLevel splayer s-  in actor--getPlayerItem :: State -> [Item]-getPlayerItem s@State{splayer} =-  let (_, _, items) = findActorAnyLevel splayer s-  in items---- | The list of actors and their levels for all heroes in the dungeon.-allHeroesAnyLevel :: State -> [ActorId]-allHeroesAnyLevel State{slid, sdungeon, sfaction} =-  let one (_, lvl) =-        [ a | (a, m) <- IM.toList $ lactor lvl-            , bfaction m == sfaction && not (bproj m) ]-  in L.concatMap one (currentFirst slid sdungeon)--updateAnyActorBody :: ActorId -> (Actor -> Actor) -> State -> State-updateAnyActorBody actor f state =-  let (ln, _, _) = findActorAnyLevel actor state-  in updateAnyLevel (updateActorDict $ IM.adjust f actor) ln state--updateAnyActorItem :: ActorId -> ([Item] -> [Item]) -> State -> State-updateAnyActorItem actor f state =-  let (ln, _, _) = findActorAnyLevel actor state-      g Nothing   = Just $ f []-      g (Just is) = Just $ f is-  in updateAnyLevel (updateInv $ IM.alter g actor) ln state--updateAnyLevel :: (Level -> Level) -> LevelId -> State -> State-updateAnyLevel f ln s@State{slid, sdungeon}-  | ln == slid = updateLevel f s-  | otherwise = updateDungeon (const $ adjust f ln sdungeon) s---- | Calculate the location of player's target.-targetToLoc :: IS.IntSet -> State -> Point -> Maybe Point-targetToLoc visible s@State{slid, scursor} aloc =-  case btarget (getPlayerBody s) of-    TLoc loc -> Just loc-    TPath [] -> Nothing-    TPath (dir:_) -> Just $ shift aloc dir-    TCursor ->-      if slid == clocLn scursor-      then Just $ clocation scursor-      else Nothing  -- cursor invalid: set at a different level-    TEnemy a _ll -> do-      guard $ memActor a s           -- alive and on the current level?-      let loc = bloc (getActor a s)-      guard $ IS.member loc visible  -- visible?-      return loc---- The operations below disregard levels other than the current.---- | Checks if the actor is present on the current level.--- The order of argument here and in other functions is set to allow------ > b <- gets (memActor a)-memActor :: ActorId -> State -> Bool-memActor a state = IM.member a (lactor (slevel state))---- | Gets actor body from the current level. Error if not found.-getActor :: ActorId -> State -> Actor-getActor a state = lactor (slevel state) IM.! a---- | Gets actor's items from the current level. Empty list, if not found.-getActorItem :: ActorId -> State -> [Item]-getActorItem a state = fromMaybe [] $ IM.lookup a (linv (slevel state))---- | Removes the actor, if present, from the current level.-deleteActor :: ActorId -> State -> State-deleteActor a =-  updateLevel (updateActorDict (IM.delete a) . updateInv (IM.delete a))---- | Add actor to the current level.-insertActor :: ActorId -> Actor -> State -> State-insertActor a m = updateLevel (updateActorDict (IM.insert a m))---- | Removes a player from the current level.-deletePlayer :: State -> State-deletePlayer s@State{splayer} = deleteActor splayer s---- TODO: unify, rename-hostileAssocs :: Kind.Id FactionKind -> Level -> [(ActorId, Actor)]-hostileAssocs faction lvl =-  filter (\ (_, m) -> bfaction m /= faction && not (bproj m)) $-    IM.toList $ lactor lvl-heroList, hostileList, dangerousList :: State -> [Actor]-heroList state@State{sfaction} =-  filter (\ m -> bfaction m == sfaction && not (bproj m)) $-    IM.elems $ lactor $ slevel state-hostileList state@State{sfaction} =-  filter (\ m -> bfaction m /= sfaction && not (bproj m)) $-    IM.elems $ lactor $ slevel state-dangerousList state@State{sfaction} =-  filter (\ m -> bfaction m /= sfaction) $-    IM.elems $ lactor $ slevel state--factionAssocs :: [Kind.Id FactionKind] -> Level -> [(ActorId, Actor)]-factionAssocs l lvl =-  filter (\ (_, m) -> bfaction m `elem` l) $ IM.toList $ lactor lvl--factionList :: [Kind.Id FactionKind] -> State -> [Actor]-factionList l s =-  filter (\ m -> bfaction m `elem` l) $ IM.elems $ lactor $ slevel s---- | Finds an actor at a location on the current level. Perception irrelevant.-locToActor :: Point -> State -> Maybe ActorId-locToActor loc state =-  let l = locToActors loc state-  in assert (L.length l <= 1 `blame` l) $-     listToMaybe l--locToActors :: Point -> State -> [ActorId]-locToActors loc state =-    let l  = IM.assocs $ lactor $ slevel state-        im = L.filter (\ (_i, m) -> bloc m == loc) l-    in fmap fst im--nearbyFreeLoc :: Kind.Ops TileKind -> Point -> State -> Point-nearbyFreeLoc cotile start state =-  let lvl@Level{lxsize, lysize, lactor} = slevel state-      locs = start : L.nub (concatMap (vicinity lxsize lysize) locs)-      good loc = Tile.hasFeature cotile F.Walkable (lvl `at` loc)-                 && unoccupied (IM.elems lactor) loc-  in fromMaybe (assert `failure` ("too crowded map" :: Text))-     $ L.find good locs---- | Calculate loot's worth for heroes on the current level.-calculateTotal :: Kind.Ops ItemKind -> State -> ([Item], Int)-calculateTotal coitem s =-  let ha = factionAssocs [sfaction s] $ slevel s-      heroInv = L.concat $ catMaybes $-                  L.map ( \ (k, _) -> IM.lookup k $ linv $ slevel s) ha-  in (heroInv, L.sum $ L.map (itemPrice coitem) heroInv)--foesAdjacent :: X -> Y -> Point -> [Actor] -> Bool-foesAdjacent lxsize lysize loc foes =-  let vic = IS.fromList $ vicinity lxsize lysize loc-      lfs = IS.fromList $ L.map bloc foes-  in not $ IS.null $ IS.intersection vic lfs---- Adding heroes--tryFindHeroK :: State -> Int -> Maybe ActorId-tryFindHeroK s k =-  let c | k == 0          = '@'-        | k > 0 && k < 10 = Char.intToDigit k-        | otherwise       = assert `failure` k-  in fmap fst $ tryFindActor s ((== Just c) . bsymbol)---- | Create a new hero on the current level, close to the given location.-addHero :: Kind.COps -> Point -> ConfigUI -> State -> State-addHero Kind.COps{coactor, cotile} ploc configUI-        state@State{scounter, sfaction} =-  let Config{configBaseHP} = sconfig state-      loc = nearbyFreeLoc cotile ploc state-      freeHeroK = L.elemIndex Nothing $ map (tryFindHeroK state) [0..9]-      n = fromMaybe 100 freeHeroK-      symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n-      name = findHeroName configUI n-      startHP = configBaseHP - (configBaseHP `div` 5) * min 3 n-      m = template (heroKindId coactor) (Just symbol) (Just name)-                   startHP loc (stime state) sfaction False-      cstate = state { scounter = scounter + 1 }-  in updateLevel (updateActorDict (IM.insert scounter m)) cstate---- | Create a set of initial heroes on the current level, at location ploc.-initialHeroes :: Kind.COps -> Point -> ConfigUI -> State -> State-initialHeroes cops ploc configUI state =-  let Config{configExtraHeroes} = sconfig state-      k = 1 + configExtraHeroes-  in iterate (addHero cops ploc configUI) state !! k---- Adding monsters---- | Create a new monster in the level, at a given position--- and with a given actor kind and HP.-addMonster :: Kind.Ops TileKind -> Kind.Id ActorKind -> Int -> Point-           -> Kind.Id FactionKind -> Bool -> State -> State-addMonster cotile mk hp ploc bfaction bproj state@State{scounter} = do-  let loc = nearbyFreeLoc cotile ploc state-      m = template mk Nothing Nothing hp loc (stime state) bfaction bproj-      cstate = state {scounter = scounter + 1}-  updateLevel (updateActorDict (IM.insert scounter m)) cstate---- Adding projectiles---- | Create a projectile actor containing the given missile.-addProjectile :: Kind.COps -> Item -> Point -> Kind.Id FactionKind-              -> [Point] -> Time -> State -> State-addProjectile Kind.COps{coactor, coitem=coitem@Kind.Ops{okind}}-              item loc bfaction path btime state@State{scounter} =-  let ik = okind (jkind item)-      speed = speedFromWeight (iweight ik) (itoThrow ik)-      range = rangeFromSpeed speed-      adj | range < 5 = "falling"-          | otherwise = "flying"-      object = partItem coitem state item-      name = makePhrase [MU.AW $ MU.Text adj, object]-      dirPath = take range $ displacePath path-      m = Actor-        { bkind   = projectileKindId coactor-        , bsymbol = Nothing-        , bname   = Just name-        , bcolor  = Nothing-        , bspeed  = Just speed-        , bhp     = 0-        , bdir    = Nothing-        , btarget = TPath dirPath-        , bloc    = loc-        , bletter = 'a'-        , btime-        , bwait   = timeZero-        , bfaction-        , bproj   = True-        }-      cstate = state { scounter = scounter + 1 }-      upd = updateActorDict (IM.insert scounter m)-            . updateInv (IM.insert scounter [item])-  in updateLevel upd cstate

@@ -1,128 +0,0 @@--- | Screen frames and animations.-module Game.LambdaHack.Animation-  ( Attr(..), defaultAttr, AttrChar(..)-  , SingleFrame(..), Animation, rederAnim-  , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces-  ) where--import qualified Data.IntMap as IM-import Data.Maybe-import qualified Data.List as L-import Data.Monoid-import Data.Text (Text)--import Game.LambdaHack.PointXY-import Game.LambdaHack.Point-import Game.LambdaHack.Color---- | The data sufficent to draw a single game screen frame.-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-  }-  deriving Eq---- | Animation is a list of frame modifications to play one by one,--- where each modification if a map from locations to level map symbols.-newtype Animation = Animation [IM.IntMap AttrChar]--instance Monoid Animation where-  mempty = Animation []-  mappend (Animation a1) (Animation a2) = Animation (a1 ++ a2)---- | Render animations on top of a screen frame.-rederAnim :: X -> Y -> SingleFrame -> Animation-          -> [Maybe SingleFrame]-rederAnim lxsize lysize basicFrame (Animation anim) =-  let modifyFrame SingleFrame{sfLevel = levelOld, ..} am =-        let fLine y lineOld =-              let f l (x, acOld) =-                    let loc = toPoint lxsize (PointXY (x, y))-                        !ac = fromMaybe acOld $ IM.lookup loc am-                    in ac : l-              in L.foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))-            sfLevel =  -- Fully evaluated.-              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 (modifyFrame basicFrame) anim--blank :: Maybe AttrChar-blank = Nothing--coloredSymbol :: Color -> Char -> Maybe AttrChar-coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol--mzipPairs :: (Maybe Point, Maybe Point) -> (Maybe AttrChar, Maybe AttrChar)-          -> [(Point, AttrChar)]-mzipPairs (mloc1, mloc2) (mattr1, mattr2) =-  let mzip (Just loc, Just attr) = Just (loc, attr)-      mzip _ = Nothing-  in if mloc1 /= mloc2-     then catMaybes [mzip (mloc1, mattr1), mzip (mloc2, mattr2)]-     else -- If actor affects himself, show only the effect, not the action.-          catMaybes [mzip (mloc1, mattr1)]---- | Attack animation. A part of it also reused for self-damage and healing.-twirlSplash :: (Maybe Point, Maybe Point) -> Color -> Color -> Animation-twirlSplash locs c1 c2 = Animation $ map (IM.fromList . mzipPairs locs)-  [ (coloredSymbol BrWhite '*', blank)-  , (coloredSymbol c1      '/', coloredSymbol BrCyan '^')-  , (coloredSymbol c1      '-', blank)-  , (coloredSymbol c1      '\\',blank)-  , (coloredSymbol c1      '|', blank)-  , (coloredSymbol c2      '/', blank)-  , (coloredSymbol c2      '%', coloredSymbol BrCyan '^')-  , (coloredSymbol c2      '%', blank)-  , (blank                    , blank)-  ]---- | Attack that hits through a block.-blockHit :: (Maybe Point, Maybe Point) -> Color -> Color -> Animation-blockHit locs c1 c2 = Animation $ map (IM.fromList . mzipPairs locs)-  [ (coloredSymbol BrWhite '*', blank)-  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')-  , (coloredSymbol BrBlue  '{', blank)-  , (coloredSymbol c1      '}', blank)-  , (coloredSymbol c1      '}', coloredSymbol BrCyan '^')-  , (coloredSymbol c2      '/', blank)-  , (coloredSymbol c2      '%', blank)-  , (coloredSymbol c2      '%', blank)-  , (blank                    , blank)-  ]---- | Attack that is blocked.-blockMiss :: (Maybe Point, Maybe Point) -> Animation-blockMiss locs = Animation $ map (IM.fromList . mzipPairs locs)-  [ (coloredSymbol BrWhite '*', blank)-  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (blank                    , blank)-  ]---- | Death animation for an organic body.-deathBody :: Point -> Animation-deathBody loc = Animation $ map (maybe IM.empty (IM.singleton loc))-  [ coloredSymbol BrRed '\\'-  , coloredSymbol BrRed '\\'-  , coloredSymbol BrRed '|'-  , coloredSymbol BrRed '|'-  , coloredSymbol BrRed '%'-  , coloredSymbol BrRed '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   ';'-  , coloredSymbol Red   ';'-  , coloredSymbol Red   ','-  ]---- | Swap-places animation, both hostile and friendly.-swapPlaces :: (Maybe Point, Maybe Point) -> Animation-swapPlaces locs = Animation $ map (IM.fromList . mzipPairs locs)-  [ (coloredSymbol BrMagenta '.', coloredSymbol Magenta   'o')-  , (coloredSymbol BrMagenta 'd', coloredSymbol Magenta   'p')-  , (coloredSymbol Magenta   'p', coloredSymbol BrMagenta 'd')-  , (coloredSymbol Magenta   'o', blank)-  ]

@@ -1,62 +0,0 @@--- | Rectangular areas of levels and their basic operations.-module Game.LambdaHack.Area-  ( Area, vicinityXY, vicinityCardinalXY, insideXY-  , normalizeArea, grid, validArea, trivialArea, expand-  ) where--import Game.LambdaHack.PointXY-import Game.LambdaHack.VectorXY---- | The type of areas. The bottom left and the top right points.-type Area = (X, Y, X, Y)---- | All (8 at most) closest neighbours of a point within an area.-vicinityXY :: Area       -- ^ limit the search to this area-           -> PointXY    -- ^ location 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 :: Area       -- ^ limit the search to this area-                   -> PointXY    -- ^ location to find neighbours of-                   -> [PointXY]-vicinityCardinalXY area xy =-  [ res-  | dxy <- movesCardinalXY, let res = shiftXY xy dxy, insideXY res area ]---- | Checks that a point belongs to an area.-insideXY :: PointXY -> Area -> Bool-insideXY (PointXY (x, y)) (x0, y0, x1, y1) =-  x1 >= x && x >= x0 && y1 >= y && y >= y0---- | Sort the corners of an area so that the bottom left is the first point.-normalizeArea :: Area -> Area-normalizeArea (x0, y0, x1, y1) = (min x0 x1, min y0 y1, max x0 x1, max y0 y1)---- | Divide uniformly a larger area into the given number of smaller areas.-grid :: (X, Y) -> Area -> [(PointXY, Area)]-grid (nx, ny) (x0, y0, x1, y1) =-  let xd = x1 - x0-      yd = y1 - y0-      -- 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.-      xborder = if nx == 1 then 3 else 2-      yborder = if ny == 1 then 3 else 2-  in [ (PointXY (x, y), (x0 + (xd * x `div` nx) + xborder,-                         y0 + (yd * y `div` ny) + yborder,-                         x0 + (xd * (x + 1) `div` nx) - xborder,-                         y0 + (yd * (y + 1) `div` ny) - yborder))-     | x <- [0..nx-1], y <- [0..ny-1] ]---- | Checks if it's an area with at least one field.-validArea :: Area -> Bool-validArea (x0, y0, x1, y1) = x0 <= x1 && y0 <= y1---- | Checks if it's an area with exactly one field.-trivialArea :: Area -> Bool-trivialArea (x0, y0, x1, y1) = x0 == x1 && y0 == y1---- | Enlarge (or shrink) the given area on all fours sides by the amount.-expand :: Area -> Int -> Area-expand (x0, y0, x1, y1) k = (x0 - k, y0 - k, x1 + k, y1 + k)

@@ -1,145 +0,0 @@--- | Operations on the 'Area' type that involve random numbers.-module Game.LambdaHack.AreaRnd-  ( -- * Picking points inside areas-    xyInArea, mkRoom, mkVoidRoom-    -- * Choosing connections-  , connectGrid, randomConnection-    -- * Plotting corridors-  , Corridor, connectPlaces-  ) where--import qualified Data.Set as S--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.PointXY-import Game.LambdaHack.Area-import Game.LambdaHack.Random---- Picking random points inside areas---- | Pick a random point within an area.-xyInArea :: Area -> Rnd PointXY-xyInArea (x0, y0, x1, y1) = do-  rx <- randomR (x0, x1)-  ry <- randomR (y0, y1)-  return $ PointXY (rx, ry)---- | Create a random room according to given parameters.-mkRoom :: (X, Y)    -- ^ minimum size-       -> Area      -- ^ the containing area, not the room itself-       -> Rnd Area-mkRoom (xm, ym) (x0, y0, x1, y1) = do-  let area0 = (x0, y0, x1 - xm + 1, y1 - ym + 1)-  assert (validArea area0 `blame` area0) $ do-    PointXY (rx0, ry0) <- xyInArea area0-    let area1 = (rx0 + xm - 1, ry0 + ym - 1, x1, y1)-    assert (validArea area1 `blame` area1) $ do-      PointXY (rx1, ry1) <- xyInArea area1-      return (rx0, ry0, rx1, ry1)---- | Create a void room, i.e., a single point area.-mkVoidRoom :: Area     -- ^ the area in which to pick the point-           -> Rnd Area-mkVoidRoom area = assert (validArea area `blame` area) $ do-  PointXY (ry, rx) <- xyInArea area-  return (ry, rx, ry, rx)---- 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 (nx, ny) = do-  let unconnected = S.fromList [ PointXY (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 = S.fromList [ PointXY (rx, ry) ]-  connectGrid' (nx, ny) unconnected candidates []--connectGrid' :: (X, Y) -> S.Set PointXY -> S.Set PointXY-             -> [(PointXY, PointXY)]-             -> Rnd [(PointXY, PointXY)]-connectGrid' (nx, ny) unconnected candidates acc-  | S.null candidates = return $ map sortPointXY acc-  | otherwise = do-      c <- oneOf (S.toList candidates)-      -- potential new candidates:-      let ns = S.fromList $ vicinityCardinalXY (0, 0, nx-1, ny-1) c-          nu = S.delete c unconnected  -- new unconnected-          -- (new candidates, potential connections):-          (nc, ds) = S.partition (`S.member` nu) ns-      new <- if S.null ds-             then return id-             else do-               d <- oneOf (S.toList ds)-               return ((c, d) :)-      connectGrid' (nx, ny) nu (S.delete c (candidates `S.union` nc)) (new acc)---- | Pick a single random connection between adjacent areas within a grid.-randomConnection :: (X, Y) -> Rnd (PointXY, PointXY)-randomConnection (nx, ny) =-  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do-  rb <- oneOf [False, True]-  if rb || ny <= 1-    then do-      rx  <- randomR (0, nx-2)-      ry  <- randomR (0, ny-1)-      return (PointXY (rx, ry), PointXY (rx+1, ry))-    else do-      rx  <- randomR (0, nx-1)-      ry  <- randomR (0, ny-2)-      return (PointXY (rx, ry), PointXY (rx, ry+1))---- Plotting individual corridors between two areas---- | The choice of horizontal and vertical orientation.-data HV = Horiz | Vert---- | The coordinates of consecutive fields of a corridor.-type Corridor = [PointXY]---- | 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-           -> 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)]---- TODO: assert that sx1 <= tx0, etc.--- | Try to connect two places with a corridor.--- Choose entrances at least 4 tiles distant from the edges, if possible.-connectPlaces :: Area -> Area -> Rnd Corridor-connectPlaces sa@(_, _, sx1, sy1) ta@(tx0, ty0, _, _) = do-  let trim (x0, y0, x1, y1) =-        let trim4 (v0, v1) = if v1 - v0 < 8 then (v0, v1) else (v0 + 4, v1 - 4)-            (nx0, nx1) = trim4 (x0, x1)-            (ny0, ny1) = trim4 (y0, y1)-        in (nx0, ny0, nx1, ny1)-  PointXY (sx, sy) <- xyInArea $ trim sa-  PointXY (tx, ty) <- xyInArea $ trim ta-  let xarea = (sx1+2, min sy ty, tx0-2, max sy ty)-      yarea = (sx, sy1+2, tx, ty0-2)-      xyarea = (sx1+2, sy1+2, tx0-2, ty0-2)-  (hv, area) <- if validArea xyarea-                then fmap (\ hv -> (hv, xyarea)) (oneOf [Horiz, Vert])-                else if validArea xarea-                     then return (Horiz, xarea)-                     else return (Vert, normalizeArea yarea)  -- vertical bias-  let (p0, p1) = case hv of-        Horiz -> (PointXY (if trivialArea sa then sx else sx1 + 1, sy),-                  PointXY (if trivialArea ta then tx else tx0 - 1, ty))-        Vert  -> (PointXY (sx, if trivialArea sa then sy else sy1 + 1),-                  PointXY (tx, if trivialArea ta then ty else ty0 - 1))-  -- 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.-  mkCorridor hv p0 p1 area

@@ -1,87 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Generic binding of keys to commands, procesing macros,--- printing command help. No operation in this module--- involves the 'State' or 'Action' type.-module Game.LambdaHack.Binding-  ( Binding(..), keyHelp,-  ) where--import qualified Data.Map as M-import qualified Data.List as L-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T--import qualified Game.LambdaHack.Key as K-import Game.LambdaHack.Msg-import qualified Game.LambdaHack.Command as Command---- | Bindings and other information about player commands.-data Binding a = Binding-  { kcmd   :: M.Map (K.Key, K.Modifier) (Text, Bool, a)-                                     -- ^ binding keys to commands-  , kmacro :: M.Map K.Key K.Key      -- ^ macro map-  , kmajor :: [K.Key]                -- ^ major, most often used, commands-  , kdir   :: [(K.Key, K.Modifier)]  -- ^ direction keys for moving and running-  , krevMap :: M.Map Command.Cmd K.Key-                                     -- ^ map from cmds to their main keys-  }--coImage :: M.Map K.Key K.Key -> K.Key -> [K.Key]-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 a -> [Overlay]-keyHelp Binding{kcmd, kmacro, kmajor} =-  let-    movBlurb =-      [ "Move throughout the level with 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"-      , ""-      ,"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 monsters."-      , ""-      , "Press SPACE to see the next page, with the list of major commands."-      ]-    majorBlurb =-      [ ""-      , "Commands marked with * take time and are blocked on remote levels."-      , "Press SPACE to see the next page, with the list of minor commands."-      ]-    minorBlurb =-      [ ""-      , "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-    keyCaption = fmt "keys" "command"-    disp k  = T.concat $ map showT $ coImage kmacro k-    keys l  = [ fmt (disp k) (h <> if timed then "*" else "")-              | ((k, _), (h, timed, _)) <- l, h /= "" ]-    (kcMajor, kcMinor) =-      L.partition ((`elem` kmajor) . fst . fst) (M.toAscList kcmd)-  in-    [ [blank] ++ mov-    , [blank] ++ [keyCaption] ++ keys kcMajor ++ major-    , [blank] ++ [keyCaption] ++ keys kcMinor ++ minor-    ]

@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Binding of keys to commands implemented with the 'Action' monad.-module Game.LambdaHack.BindingAction-  ( stdBinding-  ) where--import Control.Monad.State hiding (State, state)-import qualified Data.List as L-import qualified Data.Map as M-import qualified Data.Char as Char-import Data.Tuple (swap)-import Data.Text (Text)--import Game.LambdaHack.Action-import Game.LambdaHack.State-import Game.LambdaHack.Config-import Game.LambdaHack.Level-import Game.LambdaHack.Actions-import Game.LambdaHack.Running-import Game.LambdaHack.EffectAction-import Game.LambdaHack.Binding-import qualified Game.LambdaHack.Key as K-import Game.LambdaHack.ActorState-import Game.LambdaHack.Command-import Game.LambdaHack.CommandAction--heroSelection :: [((K.Key, K.Modifier), (Text, Bool, ActionFrame ()))]-heroSelection =-  let select k = do-        s <- get-        case tryFindHeroK s k of-          Nothing -> abortWith "No such member of the party."-          Just aid -> selectPlayer aid >> returnNoFrame ()-      heroSelect k = ( (K.Char (Char.intToDigit k), K.NoModifier)-                     , ("", False, select k)-                     )-  in fmap heroSelect [0..9]---- | Binding of keys to movement and other standard commands,--- as well as commands defined in the config file.-stdBinding :: ConfigUI                  -- ^ game config-           -> Binding (ActionFrame ())  -- ^ concrete binding-stdBinding !config@ConfigUI{configMacros} =-  let kmacro = M.fromList $ configMacros-      cmdList = configCmds config-      semList = semanticsCmds cmdList-      moveWidth f = do-        lxsize <- gets (lxsize . slevel)-        move $ f lxsize-      runWidth f = do-        lxsize <- gets (lxsize . slevel)-        run (f lxsize, 0)-      -- Targeting cursor movement and others are wrongly marked as timed;-      -- fixed in their definitions by rewinding time.-      cmdDir = K.moveBinding moveWidth runWidth-  in Binding-  { kcmd   = M.fromList $-             cmdDir ++-             heroSelection ++-             semList ++-             [ -- Debug commands.-               ((K.Char 'r', K.Control), ("", False, modify cycleMarkVision-                                                     >> returnNoFrame ())),-               ((K.Char 'o', K.Control), ("", False, modify toggleOmniscient-                                                     >> returnNoFrame ())),-               ((K.Char 'i', K.Control), ("", False, gets (lmeta . slevel)-                                                     >>= abortWith))-             ]-  , kmacro-  , kmajor = L.map fst $ L.filter (majorCmd . snd) cmdList-  , kdir   = L.map fst cmdDir-  , krevMap = M.fromList $ map swap cmdList-  }

@@ -1,23 +0,0 @@--- | A game requires the engine provided by the library, perhaps customized,--- and game content, defined completely afresh for the particular game.--- The general type of the content is @CDefs@ and it has instances--- for all content kinds, such as items kinds--- (@Game.LambdaHack.Content.ItemKind@).--- The possible kinds are fixed in the library and all defined in the same--- directory. On the other hand, game content, that is all elements--- of @CDefs@ instances, are defined in a directory--- of the game code proper, with names corresponding to their kinds.-module Game.LambdaHack.CDefs (CDefs(..)) where--import Data.Text (Text)--import Game.LambdaHack.Misc---- | The general type of a particular game content, e.g., item kinds.-data CDefs a = CDefs-  { getSymbol :: a -> Char    -- ^ symbol, e.g., to print on the map-  , getName   :: a -> Text    -- ^ name, e.g., to show to the player-  , getFreq   :: a -> Freqs   -- ^ frequency within groups-  , validate  :: [a] -> [a]   -- ^ validate and catch some offenders, if any-  , content   :: [a]          -- ^ all the defined content of this type-  }

@@ -1,206 +0,0 @@--- | Generation of caves (not yet inhabited dungeon levels) from cave kinds.-module Game.LambdaHack.Cave-  ( TileMapXY, SecretMapXY, ItemMapXY, Cave(..), buildCave-  ) where--import Control.Monad-import qualified Data.Map as M-import qualified Data.List as L-import Data.Maybe-import Data.Text (Text)--import Game.LambdaHack.Utils.Assert-import Game.LambdaHack.PointXY-import Game.LambdaHack.Area-import Game.LambdaHack.AreaRnd-import Game.LambdaHack.Item-import Game.LambdaHack.Random-import qualified Game.LambdaHack.Tile as Tile-import qualified Game.LambdaHack.Kind as Kind-import Game.LambdaHack.Content.CaveKind-import Game.LambdaHack.Content.TileKind-import qualified Game.LambdaHack.Feature as F-import Game.LambdaHack.Place hiding (TileMapXY)-import qualified Game.LambdaHack.Place as Place-import Game.LambdaHack.Misc-import Game.LambdaHack.Time-import Game.LambdaHack.Msg---- | 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 @cdefaultTile@.-type TileMapXY = Place.TileMapXY---- | The map of starting secrecy strength of tiles in a cave.--- The map is sparse. Unspecified tiles have secrecy strength of 0.-type SecretMapXY = M.Map PointXY Tile.SecretTime---- | The map of starting items in tiles of a cave. The map is sparse.--- Unspecified tiles have no starting items.-type ItemMapXY = M.Map PointXY Item---- | 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-  , dsecret   :: SecretMapXY          -- ^ secrecy strength of cave tiles-  , ditem     :: ItemMapXY            -- ^ starting items in the cave-  , dmeta     :: Text                 -- ^ debug information about the cave-  , dplaces   :: [Place]              -- ^ places generated in the cave-  }-  deriving Show--{--Rogue cave is generated by an algorithm inspired by the original Rogue,-as follows:--  * The available area is divided into a grid, e.g, 3 by 3,-    where each of the 9 grid cells has approximately the same size.--  * In each of the 9 grid cells one room is placed at a random location-    and with a random size, but larger than The minimum size,-    e.g, 2 by 2 floor tiles.--  * Rooms that are on horizontally or vertically adjacent grid cells-    may be connected by a corridor. Corridors consist of 3 segments of straight-    lines (either "horizontal, vertical, horizontal" or "vertical, horizontal,-    vertical"). They end in openings in the walls of the room they connect.-    It is possible that one or two of the 3 segments have length 0, such that-    the resulting corridor is L-shaped or even a single straight line.--  * Corridors are generated randomly in such a way that at least every room-    on the grid is connected, and a few more might be. It is not sufficient-    to always connect all adjacent rooms.--}--- TODO: fix identifier naming and split, after the code grows some more--- | Cave generation by an algorithm inspired by the original Rogue,-buildCave :: Kind.COps         -- ^ content definitions-          -> Int               -- ^ depth of the level to generate-          -> 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{okind=tokind, opick}-                        , cocave=Kind.Ops{okind} }-          ln depth ci = do-  let kc@CaveKind{..} = okind ci-  lgrid@(gx, gy) <- rollDiceXY cgrid-  lminplace <- rollDiceXY cminPlaceSize-  let gs = grid lgrid (0, 0, cxsize - 1, cysize - 1)-  mandatory1 <- replicateM (cnonVoidMin `div` 2) $-                  xyInArea (0, 0, gx `div` 3, gy - 1)-  mandatory2 <- replicateM (cnonVoidMin `divUp` 2) $-                  xyInArea (gx - 1 - (gx `div` 3), 0, gx - 1, gy - 1)-  places0 <- mapM (\ (i, r) -> do-                     rv <- chance cvoidChance-                     r' <- if rv && i `notElem` (mandatory1 ++ mandatory2)-                           then mkVoidRoom r-                           else mkRoom lminplace r-                     return (i, r')) gs-  connects <- connectGrid lgrid-  addedConnects <--    if gx * gy > 1-    then let caux = round $ cauxConnects * fromIntegral (gx * gy)-         in replicateM caux (randomConnection lgrid)-    else return []-  let allConnects = L.union connects addedConnects  -- no duplicates-      places = M.fromList places0-  cs <- mapM (\ (p0, p1) -> do-                 let r0 = places M.! p0-                     r1 = places M.! p1-                 connectPlaces r0 r1) allConnects-  wallId <- opick cfillerTile (const True)-  let fenceBounds = (1, 1, cxsize - 2, cysize - 2)-      fence = buildFence wallId fenceBounds-  pickedCorTile <- opick ccorridorTile (const True)-  let addPl (m, pls) (_, (x0, _, x1, _)) | x0 == x1 = return (m, pls)-      addPl (m, pls) (_, r) = do-        (tmap, place) <- buildPlace cops kc pickedCorTile ln depth r-        return (M.union tmap m, place : pls)-  (lplaces, dplaces) <- foldM addPl (fence, []) places0-  let lcorridors = M.unions (L.map (digCorridors pickedCorTile) cs)-  hiddenMap <- mapToHidden cotile chiddenTile-  let lm = M.unionWith (mergeCorridor cotile hiddenMap) lcorridors lplaces-  -- Convert openings into doors, possibly.-  (dmap, secretMap) <--    let f (l, le) (p, t) =-          if Tile.hasFeature cotile F.Hidden t-          then do-            -- Openings have a certain chance to be doors;-            -- doors have a certain chance to be open; and-            -- closed doors have a certain chance to be hidden-            rd <- chance cdoorChance-            if not rd-              then return (M.insert p pickedCorTile l, le)-              else do-                doorClosedId <- trigger cotile t-                doorOpenId   <- trigger cotile doorClosedId-                ro <- chance copenChance-                if ro-                  then return (M.insert p doorOpenId l, le)-                  else do-                    rs <- chance chiddenChance-                    if not rs-                      then return (M.insert p doorClosedId l, le)-                      else do-                        secret <- rollSecret (tokind t)-                        return (l, M.insert p secret le)-          else return (l, le)-    in foldM f (lm, M.empty) (M.toList lm)-  let cave = Cave-        { dkind = ci-        , dsecret = secretMap-        , ditem = M.empty-        , dmap-        , dmeta = showT allConnects-        , dplaces-        }-  return cave--rollSecret :: TileKind -> Rnd Tile.SecretTime-rollSecret t = do-  let getDice (F.Secret dice) _ = dice-      getDice _ acc = acc-      defaultDice = RollDice 5 2-      d = foldr getDice defaultDice (tfeature t)-  secretTurns <- rollDice d-  return $ timeScale timeTurn secretTurns--trigger :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)-trigger Kind.Ops{okind, opick} t =-  let getTo (F.ChangeTo group) _ = Just group-      getTo _ acc = acc-  in case foldr getTo Nothing (tfeature (okind t)) of-       Nothing    -> return t-       Just group -> opick group (const True)--digCorridors :: Kind.Id TileKind -> Corridor -> TileMapXY-digCorridors tile (p1:p2:ps) =-  M.union corPos (digCorridors tile (p2:ps))- where-  corXY  = fromTo p1 p2-  corPos = M.fromList $ L.zip corXY (repeat tile)-digCorridors _ _ = M.empty--passable :: [F.Feature]-passable = [F.Walkable, F.Openable, F.Hidden]--mapToHidden :: Kind.Ops TileKind -> Text-            -> Rnd (M.Map (Kind.Id TileKind) (Kind.Id TileKind))-mapToHidden cotile@Kind.Ops{ofoldrWithKey, opick} chiddenTile =-  let getHidden ti tk acc =-        if Tile.canBeHidden cotile tk-        then do-          ti2 <- opick chiddenTile $ \ k -> Tile.kindHasFeature F.Hidden k-                                            && Tile.similar k tk-          fmap (M.insert ti ti2) acc-        else acc-  in ofoldrWithKey getHidden (return M.empty)--mergeCorridor :: Kind.Ops TileKind-              -> M.Map (Kind.Id TileKind) (Kind.Id TileKind)-              -> Kind.Id TileKind -> Kind.Id TileKind -> Kind.Id TileKind-mergeCorridor cotile _    _ t-  | L.any (\ f -> Tile.hasFeature cotile f t) passable = t-mergeCorridor _ hiddenMap u t =-  fromMaybe (assert `failure` (u, hiddenMap, t)) $-    M.lookup t hiddenMap

@@ -0,0 +1,117 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Semantics of client commands.+-- See+-- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Client+  ( cmdClientAISem, cmdClientUISem+  , loopAI, loopUI, exeFrontend+  , MonadClient, MonadClientUI, MonadConnClient+  ) where++import Data.Maybe++import Game.LambdaHack.Client.Action+import Game.LambdaHack.Client.AtomicSemCli+import Game.LambdaHack.Client.Binding+import Game.LambdaHack.Client.ClientSem+import Game.LambdaHack.Client.Config+import Game.LambdaHack.Client.LoopAction+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Action+import Game.LambdaHack.Common.AtomicCmd+import Game.LambdaHack.Common.ClientCmd+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.State+import Game.LambdaHack.Frontend+import Game.LambdaHack.Utils.Assert++storeUndo :: MonadClient m => Atomic -> m ()+storeUndo _atomic =+  maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})+    $ Nothing   -- TODO: undoAtomic atomic++cmdClientAISem :: (MonadAtomic m, MonadConnClient c m)+               => CmdClientAI -> m ()+cmdClientAISem cmd = case cmd of+  CmdAtomicAI cmdA -> do+    cmds <- cmdAtomicFilterCli cmdA+    mapM_ cmdAtomicSemCli cmds+    mapM_ execCmdAtomic cmds+    mapM_ (storeUndo . CmdAtomic) cmds+  CmdQueryAI aid -> do+    cmdC <- queryAI aid+    ConnServer{writeConnServer} <- getConn+    writeConnServer cmdC++cmdClientUISem :: ( MonadAtomic m, MonadClientAbort m+                  , MonadClientUI m, MonadConnClient c m )+               => CmdClientUI -> m ()+cmdClientUISem cmd =+  case cmd of+    CmdAtomicUI cmdA -> do+      cmds <- cmdAtomicFilterCli cmdA+      mapM_ cmdAtomicSemCli cmds+      mapM_ execCmdAtomic cmds+      mapM_ (drawCmdAtomicUI False) cmds+      mapM_ (storeUndo . CmdAtomic) cmds  -- TODO: only store cmdA?+    SfxAtomicUI sfx -> do+      drawSfxAtomicUI False sfx+      storeUndo $ SfxAtomic sfx+    CmdQueryUI aid -> do+      mleader <- getsClient _sleader+      assert (isJust mleader `blame` cmd) skip+      ConnServer{writeConnServer} <- getConn+      cmdH <- queryUI aid+      writeConnServer cmdH++wireSession :: (SessionUI -> State -> StateClient+                -> ConnServer CmdClientUI -> IO ())+            -> (SessionUI -> State -> StateClient+                -> ConnServer CmdClientAI -> IO ())+            -> Kind.COps+            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())+                -> (FactionId -> ChanServer CmdClientAI -> IO ())+                -> IO ())+            -> IO ()+wireSession exeClientUI exeClientAI cops@Kind.COps{corule} exeServer = do+  -- UI config reloaded at each client start.+  sconfigUI <- mkConfigUI corule+  let !sbinding = stdBinding sconfigUI  -- evaluate to check for errors+      font = configFont sconfigUI+  defHist <- defHistory+  let cli = defStateClient defHist sconfigUI+      s = updateCOps (const cops) emptyState+      executorAI fid chanS =+        let noSession = assert `failure` fid+        in exeClientAI noSession s (cli fid True) (connServer chanS)+      executorUI fid fromF chanS =+        let sfconn = connFrontend fid fromF+        in exeClientUI SessionUI{..} s (cli fid False) (connServer chanS)+  startupF font $ exeServer executorUI executorAI++-- | Wire together game content, the main loop of game clients,+-- the main game loop assigned to this frontend (possibly containing+-- the server loop, if the whole game runs in one process),+-- UI config and the definitions of game commands.+exeFrontend :: ( MonadAtomic m, MonadClientAbort m, MonadClientUI m+               , MonadConnClient CmdClientUI m+               , MonadAtomic n+               , MonadConnClient CmdClientAI n )+            => (m () -> SessionUI -> State -> StateClient+                -> ConnServer CmdClientUI+                -> IO ())+            -> (n () -> SessionUI -> State -> StateClient+                -> ConnServer CmdClientAI+                -> IO ())+            -> Kind.COps+            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())+               -> (FactionId -> ChanServer CmdClientAI -> IO ())+               -> IO ())+            -> IO ()+exeFrontend executorUI executorAI cops exeServer = do+  let loopClientUI = loopUI cmdClientUISem+      loopClientAI = loopAI cmdClientAISem+      exeClientUI = executorUI loopClientUI+      exeClientAI = executorAI loopClientAI+  wireSession exeClientUI exeClientAI cops exeServer

@@ -0,0 +1,428 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Game action monads and basic building blocks for human and computer+-- player actions. Has no access to the the main action type.+-- Does not export the @liftIO@ operation nor a few other implementation+-- details.+module Game.LambdaHack.Client.Action+  ( -- * Action monads+    MonadClient( getClient, getsClient, putClient, modifyClient )+  , MonadClientUI+  , MonadConnClient( getConn )+  , MonadClientAbort( abortWith, tryWith )+  , SessionUI(..), ConnFrontend(..), connFrontend+  , ConnServer(..), connServer+    -- * 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)+  , askBinding, getPerFid+    -- * History and report+  , msgAdd, msgReset, recordHistory+    -- * Key input+  , getKeyOverlayCommand, getInitConfirms+    -- * Display and key input+  , displayFrames, displayMore, displayYesNo, displayChoiceUI+    -- * Generate slideshows+  , promptToSlideshow, overlayToSlideshow+    -- * Draw frames+  , drawOverlay, animate+    -- * Assorted primitives+  , clientGameSave, restoreGame, displayPush, scoreToSlideshow+  , rndToAction, getArenaUI, getLeaderUI+  , targetToPos, partAidLeader, partActorLeader+  , debugPrint+  ) where++import Control.Concurrent+import Control.Concurrent.STM+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.Map.Strict as M+import Data.Maybe+import qualified Data.Monoid as Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified NLP.Miniutter.English as MU+import System.IO (hFlush, stderr)+import qualified System.Random as R+import System.Time++import Game.LambdaHack.Client.Action.ActionClass+import Game.LambdaHack.Client.Action.ConfigIO+import qualified Game.LambdaHack.Client.Action.Save as Save+import Game.LambdaHack.Client.Binding+import Game.LambdaHack.Client.Config+import Game.LambdaHack.Client.Draw+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 Game.LambdaHack.Common.ClientCmd+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.HighScore as HighScore+import qualified Game.LambdaHack.Common.Key as K+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.State+import Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Frontend as Frontend+import Game.LambdaHack.Utils.Assert++debugPrint :: MonadClient m => Text -> m ()+debugPrint t = do+  debug <- getsClient sdebugCli+  when debug $ liftIO $ do+    delay <- R.randomRIO (0, 1000000)+    threadDelay delay  -- try not to interleave letters with other clients+    T.hPutStrLn stderr t+    hFlush stderr++connFrontend :: FactionId -> Frontend.ChanFrontend -> ConnFrontend+connFrontend fid fromF = ConnFrontend+  { readConnFrontend =+      liftIO $ atomically $ readTQueue fromF+  , writeConnFrontend = \efr -> do+      let toF = Frontend.toMulti Frontend.connMulti+      liftIO $ atomically $ writeTQueue toF (fid, efr)+  }++connServer :: ChanServer c -> ConnServer c+connServer ChanServer{..} = ConnServer+  { readConnServer =  liftIO . atomically . readTQueue $ fromServer+  , writeConnServer = liftIO . atomically . writeTQueue toServer+  }++-- | Reset the state and resume from the last backup point, i.e., invoke+-- the failure continuation.+abort :: MonadClientAbort m => m a+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` msg <+> "in tryIgnore")++-- | 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+  let frame = case mf of+        Nothing -> AcDelay+        Just fr | isRunning -> AcRunning fr+        Just fr -> AcNormal fr+  writeConnFrontend $ Frontend.FrontFrame frame++promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM+promptGetKey frontKM frontFr = do+  ConnFrontend{..} <- getsSession sfconn+  writeConnFrontend Frontend.FrontKey {..}+  readConnFrontend++-- | Display a slideshow, awaiting confirmation for each slide except the last.+getInitConfirms :: MonadClientUI m => [K.KM] -> Slideshow -> m Bool+getInitConfirms frontClear slides = do+  ConnFrontend{..} <- getsSession sfconn+  frontSlides <- mapM (drawOverlay ColorFull) $ runSlideshow slides+  -- The first two cases are optimizations:+  case frontSlides of+    [] -> return True+    [x] -> do+      displayFrame False $ Just x+      return True+    _ -> do+      writeConnFrontend Frontend.FrontSlides{..}+      km <- readConnFrontend+      return $! km /= K.KM {key=K.Esc, modifier=K.NoModifier}++getLeaderUI :: MonadClientUI m => m ActorId+getLeaderUI = do+  cli <- getClient+  case _sleader cli of+    Nothing -> assert `failure` 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+      dungeon <- getsState sdungeon+      case EM.minViewWithKey dungeon of+        Just ((s, _), _) -> return s+        Nothing -> assert `failure` dungeon++-- | 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++-- | Add a message to the current report.+msgAdd :: MonadClientUI m => Msg -> m ()+msgAdd msg = modifyClient $ \d -> d {sreport = addMsg (sreport d) msg}++-- | Wipe out and set a new value for the current report.+msgReset :: MonadClient m => Msg -> m ()+msgReset msg = modifyClient $ \d -> d {sreport = singletonReport msg}++-- | Store current report in the history and reset report.+recordHistory :: MonadClient m => m ()+recordHistory = do+  StateClient{sreport, shistory} <- getClient+  unless (nullReport sreport) $ do+    ConfigUI{configHistoryMax} <- getsClient sconfigUI+    msgReset ""+    let nhistory = takeHistory configHistoryMax $! addReport sreport shistory+    modifyClient $ \cli -> cli {shistory = nhistory}++-- | Get the current perception of a client.+getPerFid :: MonadClient m => LevelId -> m Perception+getPerFid lid = do+  fper <- getsClient sfper+  return $! fromMaybe (assert `failure` lid) $ 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+  -- Give the previous client time to display his frames.+  liftIO $ threadDelay 1000+  km <- promptGetKey [] frame+  return $! fromMaybe km $ M.lookup km $ kmacro keyb++getConfirm :: MonadClientUI m => [K.KM] -> SingleFrame -> m Bool+getConfirm = Frontend.getConfirmGeneric promptGetKey++-- | Push frames or delays to the frame queue.+displayFrames :: MonadClientUI m => Frames -> m ()+displayFrames = mapM_ (displayFrame False)++-- | A yes-no confirmation.+getYesNo :: MonadClientUI m => SingleFrame -> m Bool+getYesNo frame = do+  let keys = [ K.KM {key=K.Char 'y', modifier=K.NoModifier}+             , K.KM {key=K.Char 'n', modifier=K.NoModifier}+             , K.KM {key=K.Esc, modifier=K.NoModifier}+             ]+  K.KM {key} <- promptGetKey keys frame+  case key of+    K.Char 'y' -> return True+    _          -> return False++-- | Display a msg with a @more@ prompt. Return value indicates if the player+-- tried to cancel/escape.+displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool+displayMore dm prompt = do+  sli <- promptToSlideshow $ prompt <+> moreMsg+  frame <- drawOverlay dm $ head $ runSlideshow sli+  getConfirm [] frame++-- | 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+  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 prompt ov keys = do+  slides <- fmap runSlideshow $ overlayToSlideshow (prompt <> ", ESC]") ov+  let legalKeys =+        [ K.KM {key=K.Space, modifier=K.NoModifier}+        , K.KM {key=K.Esc, modifier=K.NoModifier} ]+        ++ keys+      loop [] = neverMind True+      loop (x : xs) = do+        frame <- drawOverlay ColorFull x+        km@K.KM {..} <- promptGetKey legalKeys frame+        case key of+          K.Esc -> neverMind True+          K.Space -> loop xs+          _ -> return km+  loop slides++-- | 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 []++-- | 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+-- to history. The portions of overlay that fit on the the rest+-- of the screen are displayed below. As many slides as needed are shown.+overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow+overlayToSlideshow prompt overlay = do+  lid <- getArenaUI+  lysize <- getsLevel lid lysize  -- TODO: screen length or viewLevel+  sreport <- getsClient sreport+  let msg = splitReport (addMsg sreport prompt)+  return $! splitOverlay lysize msg overlay++-- | Draw the current level with the overlay on top.+drawOverlay :: MonadClientUI m => ColorMode -> Overlay -> m SingleFrame+drawOverlay dm over = do+  cops <- getsState scops+  stgtMode <- getsClient stgtMode+  arena <- getArenaUI+  let lid = maybe arena tgtLevelId stgtMode+  mleader <- getsClient _sleader+  s <- getState+  cli <- getClient+  per <- getPerFid lid+  return $! draw dm cops per lid mleader cli s over++-- | Push the frame depicting the current level to the frame queue.+-- Only one screenful of the report is shown, the rest is ignored.+displayPush :: MonadClientUI m => m ()+displayPush = do+  sls <- promptToSlideshow ""+  let slide = head $ runSlideshow sls+  frame <- drawOverlay 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+  displayFrame (isJust srunning) $ Just frame++scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow+scoreToSlideshow total status = do+  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++saveName :: FactionId -> Bool -> String+saveName side isAI =+  let n = fromEnum side+  in (if n > 0+      then "human_" ++ show n+      else "computer_" ++ show (-n))+     ++ if isAI then ".ai.sav" else ".ui.sav"++clientGameSave :: MonadClient m => Bool -> m ()+clientGameSave toBkp = do+  s <- getState+  cli <- getClient+  configUI <- getsClient sconfigUI+  side <- getsClient sside+  isAI <- getsClient sisAI+  liftIO $ Save.saveGameCli (saveName side isAI) toBkp configUI s cli++restoreGame :: MonadClient m => m (Either (State, StateClient, Msg) Msg)+restoreGame = do+  Kind.COps{corule} <- getsState scops+  configUI <- getsClient sconfigUI+  let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule+      title = rtitle $ Kind.stdRuleset corule+  side <- getsClient sside+  isAI <- getsClient sisAI+  let sName = saveName side isAI+  liftIO $ Save.restoreGameCli sName configUI pathsDataFile title++-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: MonadClient m => Rnd a -> m a+rndToAction r = do+  g <- getsClient srandom+  let (a, ng) = St.runState r g+  modifyClient $ \cli -> cli {srandom = ng}+  return a++-- TODO: perhaps draw viewed level, not arena+-- TODO: restrict the animation to 'per' before drawing.+-- | Render animations on top of the current screen frame.+animate :: MonadClientUI m => LevelId -> Animation -> m Frames+animate arena anim = do+  cops <- getsState scops+  sreport <- getsClient sreport+  mleader <- getsClient _sleader+  Level{lxsize, lysize} <- getsLevel arena id+  cli <- getClient+  s <- getState+  per <- getPerFid arena+  let over = renderReport sreport+      topLineOnly = truncateMsg lxsize over+      basicFrame = draw ColorFull cops per arena mleader cli s [topLineOnly]+  return $ renderAnim lxsize lysize basicFrame anim++-- | The part of speech describing the actor or a special name if a leader+-- of the observer's faction. The actor may not be present in the dungeon.+partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part+partActorLeader aid b = do+  Kind.COps{coactor} <- getsState scops+  mleader <- getsClient _sleader+  return $! case mleader of+    Just leader | aid == leader -> "you"+    _ -> partActor coactor b++-- | The part of speech describing the actor (designated by actor id+-- and present in the dungeon) or a special name if a leader+-- of the observer's faction.+partAidLeader :: MonadClient m => ActorId -> m MU.Part+partAidLeader aid = do+  b <- getsState $ getActorBody aid+  partActorLeader aid b

@@ -0,0 +1,75 @@+{-# LANGUAGE FunctionalDependencies, RankNTypes #-}+-- | Basic type classes for game actions.+-- This module should not be imported anywhere except in 'Action'+-- 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.Msg+import Game.LambdaHack.Common.ServerCmd+import Game.LambdaHack.Frontend (FrontReq)++-- | The information that is constant across a client playing session,+-- including many consecutive games in a single session,+-- but is completely disregarded and reset when a new playing session starts.+-- Auxiliary AI and computer player clients have no @sfs@ nor @sbinding@.+data SessionUI = SessionUI+  { sfconn   :: !ConnFrontend  -- ^ connection with the frontend+  , sbinding :: !Binding       -- ^ binding of keys to commands+  }++-- | Connection method between a client and a frontend.+data ConnFrontend = ConnFrontend+  { readConnFrontend  :: MonadClientUI m => m K.KM+      -- ^ read a keystroke received from the frontend+  , writeConnFrontend :: MonadClientUI m => FrontReq -> m ()+      -- ^ write a UI request to the frontend+  }++data ConnServer c = ConnServer+  { readConnServer  :: MonadConnClient c m => m c+  , writeConnServer :: MonadConnClient c m => CmdSer -> m ()+  }++class MonadActionRO m => MonadClient m where+  getClient    :: m StateClient+  getsClient   :: (StateClient -> a) -> m a+  modifyClient :: (StateClient -> StateClient) -> m ()+  putClient    :: StateClient -> m ()+  -- We do not provide a MonadIO instance, so that outside of Action/+  -- nobody can subvert the action monads by invoking arbitrary IO.+  liftIO       :: IO a -> m a++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++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 => MonadConnClient c m | m -> c where+  getConn  :: m (ConnServer c)++-- | 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

@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}+-- | 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+  ) where++import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import qualified System.Random as R++import Game.LambdaHack.Client.Action.ActionClass+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Action+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.State++-- | The type of the function inside any client action.+type FunActionCli c a =+   SessionUI                          -- ^ client UI setup data+   -> ConnServer c                          -- ^ 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 a = ActionCli {runActionCli :: FunActionCli c a}++-- | Invokes the action continuation on the provided argument.+returnActionCli :: a -> ActionCli c a+returnActionCli x = ActionCli (\_c _d k _a s cli -> k s cli x)++-- | Distributes the session and shutdown continuation,+-- threads the state and history.+bindActionCli :: ActionCli c a -> (a -> ActionCli c b) -> ActionCli c b+bindActionCli m f = ActionCli (\c d k a s cli ->+                          let next ns ncli x =+                                runActionCli (f x) c d k a ns ncli+                          in runActionCli m c d next a s cli)++instance Monad (ActionCli c) where+  return = returnActionCli+  (>>=)  = bindActionCli++-- TODO: make sure fmap is inlined and all else is inlined here and elsewhere+instance Functor (ActionCli c) where+  fmap f m =+    ActionCli (\c d k a s cli ->+               runActionCli m c d (\s' cli' ->+                                 k s' cli' . f) a s cli)++instance Show (ActionCli c a) where+  show _ = "an action"++instance MonadClientAbort (ActionCli c) where+  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)++instance MonadActionRO (ActionCli c) where+  getState       = ActionCli (\_c _d k _a s cli -> k s cli s)+  getsState      = (`fmap` getState)++instance MonadAction (ActionCli c) where+  modifyState f  = ActionCli (\_c _d k _a s cli -> k (f s) cli ())+  putState       = modifyState . const++instance MonadClient (ActionCli c) 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)++instance MonadClientUI (ActionCli c) where+  getsSession f  = ActionCli (\c _d k _a s cli -> k s cli (f c))++instance MonadConnClient c (ActionCli c) where+  getConn        = ActionCli (\_c d k _a s cli -> k s cli d)++-- | Run an action, with a given session, state and history, in the @IO@ monad.+executorCli :: ActionCli c ()+            -> SessionUI -> State -> StateClient -> ConnServer c+            -> IO ()+executorCli m sess s cli d =+  runActionCli m+    sess+    d+    (\_ _ _ -> return ())+    (\_ msg -> let err = "unhandled abort for client"+                         <+> showT (sfactionD s EM.! sside cli)+                         <+> ":" <+> msg+               in fail $ T.unpack err)+    s+    cli

@@ -0,0 +1,122 @@+-- | Personal game configuration file support.+module Game.LambdaHack.Client.Action.ConfigIO+  ( mkConfigUI+  ) where++import Control.DeepSeq+import qualified Data.Char as Char+import qualified Data.ConfigFile as CF+import System.Directory+import System.Environment+import System.FilePath++import Game.LambdaHack.Client.Config+import Game.LambdaHack.Client.HumanCmd+import qualified Game.LambdaHack.Common.Key as K+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Utils.Assert++-- TODO: Refactor the client and server ConfigIO.hs, after+-- https://github.com/kosmikus/LambdaHack/issues/45.++overrideCP :: CP -> FilePath -> IO CP+overrideCP cp@(CP defCF) cfile = do+  b <- doesFileExist cfile+  if not b+    then return cp+    else do+      c <- CF.readfile defCF cfile+      return $ toCP $ 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 CPP.+-- The player configuration comes from file @cfile@.+mkConfig :: String -> FilePath -> IO CP+mkConfig configDefault cfile = do+  let delComment = map (drop 2) $ init . drop 3 $ lines configDefault+      unConfig = unlines delComment+      -- Evaluate, to catch config errors ASAP.+      !defCF = 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++-- | 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}++-- | In case of corruption, just fail.+forceEither :: Show a => Either a b -> b+forceEither (Left a)  = assert `failure` a+forceEither (Right b) = b++-- | Simplified access to an option in a given section.+-- Fails if the option is not present.+get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a+get (CP conf) s o =+  if CF.has_option conf s o+  then forceEither $ CF.get conf s o+  else assert `failure` "Unknown config option: " ++ s ++ "." ++ o++-- | An association list corresponding to a section. Fails if no such section.+getItems :: CP -> CF.SectionSpec -> [(String, String)]+getItems (CP conf) s =+  if CF.has_section conf s+  then forceEither $ CF.items conf s+  else assert `failure` "Unknown config section: " ++ s++parseConfigUI :: FilePath -> CP -> ConfigUI+parseConfigUI dataDir cp =+  let mkKey s =+        case K.keyTranslate s of+          K.Unknown _ ->+            assert `failure` ("unknown config file key <" ++ s ++ ">")+          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 = getItems cp "commands"+        in map mkCommand section+      configAppDataDirUI = dataDir+      configUICfgFile = dataDir </> "config.ui"+      configMacros =+        let trMacro (from, to) =+              let fromTr = mkKM from+                  toTr  = mkKM to+              in if fromTr == toTr+                 then assert `failure` "degenerate alias: " ++ show toTr+                 else (fromTr, toTr)+            section = getItems cp "macros"+        in map trMacro section+      configFont = get cp "ui" "font"+      configHistoryMax = get cp "ui" "historyMax"+  in ConfigUI{..}++-- | Read and parse UI config file.+mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI+mkConfigUI corule = do+  let cpUIDefault = rcfgUIDefault $ Kind.stdRuleset corule+  appData <- appDataDir+  cpUI <- mkConfig cpUIDefault $ appData </> "config.ui.ini"+  let conf = parseConfigUI appData cpUI+  -- Catch syntax errors ASAP,+  return $! deepseq conf conf