packages feed

LambdaHack 0.2.14 → 0.11.0.1

raw patch · 314 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,2119 @@+## [v0.11.0.1](https://github.com/LambdaHack/LambdaHack/compare/v0.11.0.0...v0.11.0.1)++- Split the long Content.ModeKind texts into lines, [#283](https://github.com/LambdaHack/LambdaHack/issues/283)+- In unit tests, re-use values from UnitTestHelpers and Game.LambdaHack.Common.Kind, [#286](https://github.com/LambdaHack/LambdaHack/issues/286)+- Rename unsnoc (see #300)+- Bump the bound on hsini to handle trailing whitespace properly+- Hack around a crash when TABbing during item manipulation+- Document better that macros start with Cmd_+- Correct a typo in test/Spec.hs+- Add the communication overhead explanation proposed by fYnch+- Compress detail levels and don't show paths at DetailHigh+- Balance speedrunning and explain it better in player docs+- Change failed alter message to less confusing; thanks go to Pug+- Tweak tutorial hint enums and tests+- Make lore menu with all tutorial hints+- Don't punish naughty window managers with spammy warning+- Try harder to prevent resizing in SDL+- Change install from Hackage instructions so that they work outside package dir+- Interrupt sleep and running a bit less++## [v0.11.0.0](https://github.com/LambdaHack/LambdaHack/compare/v0.10.3.0...v0.11.0.0)++- Partially work around regression in libsdl2 2.0.16 (https://github.com/LambdaHack/LambdaHack/issues/281); to also avoid deformed boxes around tiles on the game map, please switch to a different SDL2 version+- Deduplicate UI code for exiting game, with extra style points+- Create monadic test harness and use it for UI and other unit tests+- Validate empty content and fix other soundness issues revealed by unit tests+- Add extra hints in --more and similar lines when tutorial is on+- Show full history at SPACE press and let second SPACE close it+- Spawn insects in the swamp+- Remove slot letter display in menus and instead display subtle bullets+- Repurpose item slots to item roles+- Redo display and control of main menu and its submenus+- Make Teletype frontend a bit closer to playable+- Switch right pane item description display from mono to prop font+- Ensure score not zero if victory+- Add a custom SDL cursor, working around a bug in SDL2 bindings+- Gut out most content symbols; weren't used even in lore menus after all+- Add a flag to disable the costly optimizations (that give 15-25% speedup)+- Add faction kind content and redo game mode content to use it+- Display seen faction lore+- Simplify and fortify faction and client assignment code+- Make a few unique items that were identified meta-game identifiable instead+- Fix persistence of meta-game discoveries in save files+- When assigning a faction, first try the group actor was picked from+- When assigned faction is dead, don't spawn the actor+- Don't use benign weapons on projectiles not to lose the fun+- Make the unique harpoon worth saving for a unique foe+- Spawn enemies closer and fix too random spawning location+- Improve display of item's range+- Warn when SDL game windows is resized not via config file+- Ban or force sleep on levels+- Protect against unset or primitive OS locale+- Add temporary hearing aids+- Disallow generating a door beside an opening in room's wall+- Permit smaller caves and validate cave content more accurately+- Try harder to generate escape from dungeon in a level corner+- Avoid exit/escape confusion in content names and descriptions+- Extend LH game mode a descriptions since people play it instead of Allure+- Make sure every cave has a description+- Many fixes, refactorings and tweaks++## [v0.10.3.0](https://github.com/LambdaHack/LambdaHack/compare/v0.10.2.0...v0.10.3.0)++- Work around regression https://gitlab.freedesktop.org/freetype/freetype/-/issues/1076 by making the scalable square font the default as the map font; the tiny map fonts, for which there is no such workaround, won't work for anybody with freetype 2.11.0+- Enable display of details in right pane in many menus+- Switch mouse wheel to move selection now that it changes right pane display+- Make the line where messages wrap configurable in config file+- Remove rarely used options from config file and code+- Prepare client-server for delays when operating over the network+- Reveal all map at game over and make it explorable+- Don't run with -threaded, increasing speed by a couple dozen percent+- Don't show messages during enemy turn (except when under AI control)+- Spawn many actors at once with probability correlated to spawning at all+- Gut out Ubuntu Font Family fonts+- Default to more old-fashioned small fonts in LambdaHack the game+- Add a few tutorial messages, reword some in-game texts+- Move with CI from Travis to GitHub Actions (but GHA can't keep up as well)+- Add hlint to CI+- Make place content directly define legends instead of overriding them+- Add a warning that crosshair is out of flinging range+- Add ANSI display to SDL2 frontend; remove vty, hcurses and GTK frontends+- Make Teletype frontend more usable (input, speed, overlays)+- Remove sight malus from light sources to avoid micromanagement+- Keep convenience settings between new games+- Add an option to mark FOV area with grey background+- Refactor and clean up a lot of the code+- Unhardwire various constants (hat tip to Jamie)+- Fix a couple of bugs and improve documentation+- Add whole new kinds of tests (even greater hat tip to Jamie)++## [v0.10.2.0](https://github.com/LambdaHack/LambdaHack/compare/v0.9.5.0...v0.10.2.0)++- Let '?' scroll help+- Handle Alt and Shift modifiers together+- Advertise the C- Tab command instead of A-+- Ignore empty lines in history, just in case+- Don't keep trailing endlines in history+- Don't include placeholders in history.txt+- Retry explosions 10 instead of 100 times+- Point crosshair to a modified tile to easily get lore info+- Point crosshair to a bumped tile to easily get lore info+- Don't spam when reporting that crafting is forbidden+- Prevent AI from attempting to fling when challenge forbids it+- Hint about absolute paths to fonts+- Disable testing ubuntu fonts, because they can't be distributed in Debian+- If any savefile corrupted, move aside all+- Be more consistent about moving corrupted files aside+- Stop running when passing a door, etc.+- Make the game over lore headers sound more natual+- Do not mention embeds in minimal detail+- Tweak detail in one step to minimal+- Don't let distant taunts interrupt running+- Add a comment about fleeing from stash+- Help AI not to leave a scout guarding the stash+- Ensure some gems in escape scenario+- Don't show embed descriptions by default now that ~ does that easily+- Add one more typical organ symbol+- Avoid cut off descriptions of conditional effects+- Prefer weapons with burn or wound+- Pick up bad weapons if decent projectiles+- Slightly prefer weapons that have any effects+- Permit cycling through pointed-at lore with tilde+- Split chooseItemDialogMode into several functions+- Permit pointed-at lore display also outside aiming mode+- Reset the pointed at lore display sequence+- Maintain current state of lore display+- Save current state of being-aimed-at lore display+- Don't use timeout weapon if non-timeout as strong+- Add delay to pushed frames, to notice things shorter than a turn+- Pretty-print activationFlag to make it more understandable+- Replace the special periodic activation handling with effect conditions+- Replace the special effect handling under ranged with effect condition+- Set ActivationOnCombine in one case for now+- Replace EffOnSmash by ActivationOnSmash+- Add effect condition based on activation method+- Add Unless effect+- Introduce ActivationFlag in place of EffActivation type+- Make server check that melee is done with a legal weapon+- Add a failure about meleeing with not a weapon+- Get rid of a lot of spurious instances+- Don't say a hit was amusing if non-piercing damage was high+- Vary also the block messages when high armor+- Use 'a' and 'the' in dangerous item use confirmations+- Prevent safe spots near centres of big explosions+- Permit explosions to sometimes go off inside unwalkable terrain+- Don't sleep if the only friend on level is guarding the stash+- Shorten mreason text for crawl to fit in main menu with square fonts+- Don't hint to press '?' when it does nothing yet+- Avoid empty manual page at the end with square font+- Make sure spot crosshair description fits on the status line+- Don't display the aim mode prefix when inside a menu+- Experiment with item menu not insisting on selecting an item+- Talk about the relevant lore command in manual+- Hint about the relevant lore command+- Make lore display context sensitive in aiming mode+- Signal that lore command is sometimes context-sensitive+- Don't add the interruption message unless useful+- Don't wipe key status that opens main menu after automation+- Permit random flavour assignment with brightCol, etc.+- Don't make detection modal if not performed by player's faction+- Don't describe the goal tile when performing mouse goto+- Simplify turn display code, removing most of the newest additions+- Remove another spurious source of frames+- Remove spurious sources of frames+- Re-add refined *interrupted* via messages+- Ensure all frames when inside macro have one-line report only+- Display *interrupted* also when messages interrupt macros+- Factor out oneLineBasicFrame+- Declare the codebase lens-free+- Avoid distributing test.exe in Windows packages+- Use squareToUI for mouse handling in the browser+- Introduce game map coordinates: PointSquare+- Update wrt PointUI transition in other frontends+- Define UI screen coords in a separate file+- Silence messages about dead actors activating most embeds+- Make it possible to prevent the sleep effect+- Remove savefiles if config file too old+- Force savegame load result to catch errors ASAP+- Wait until browser finalizes Local Storage in the background+- Throw a Haskel exception when JS decompression fails on an old savefile+- Now that browser compresses savefiles, permit full history size+- Limit DOM keyboard focus highjacking, etc.+- Tell player when browser can be closed+- Use lz-string.js externs for minification+- Compress savefiles in GHCJS+- Bump base-compat bound to include Data.Semigroup compat+- Simplify containers for explosions+- Start embedded explosions inside the tile, not inside projectile+- Exclude meta game items from combat messages+- Move snxtScenario to session+- Avoid 'you are less more tidy'+- Don't count valuables inside organs to dungeon total+- Clarify that normal damage is piercing, as opposed to blunt wounding+- Change the misleading 'guards a hoard'+- When dropped, destroy any organs, not only conditions+- Don't hint to press ? when it would skip some messages+- Explain why the fadeout report is rendered in square font+- Show each tutorial hint at most once per game+- Require keypress when another faction killed off+- Don't show question marks in HUD for MinorAspects items+- Add MinorAspects flag+- Get rid of the mechanism for referring expressions across messages+- Commute freely messages about conditions lasting longer+- Add NopEffect+- Add AtMostOneOf effect constructor+- Assign stable faction IDs to teams with continuity+- Display also actor initial items, not only organs+- Use Condition flag, not group, for speed and simplicity+- Keep paragraphs of the same width, unless the first really short+- Add the 'stomachs' irregular plural+- Don't identify item if PutToSleep applied to sleeping actor+- Permit question marks in verb effects+- Do not announce item trigger if explicit and so already told+- Do not report conditions triggered when they vanish+- Inform differently when sleep induced by own organ, etc.+- Reflect that item triggering message appears after the fact+- Do not spam when backstory can't trigger yet+- Give more details in logs when item triggering does not work+- Do not spam about water being activated+- Prevent server failure when triggering a gold piece+- Log item application even from, e.g., periodic activation+- Don't announce that a dying actors stopped being hungry+- Add a temporary hack that prevents AI from stealing backstories in Allure+- Hardwire the player team continuity token+- Don't identify meta game items at game end+- Implement conditional effects+- At death, destroy all organs, not just the trunk+- Permit non-unique non-singleton flavours+- Render story flavours specially+- Announce identification even during melee+- Inform about discovering meta game organs+- Make sure heroes spawned in safari mode are properly numbered+- Add a few more hero names+- Improve the descritpion of MetaGame flag+- Record meta game gear for future games+- Consume current, not persistent team gear+- Create gear according to character preferences, if any+- Use server-assigned actor numbers in the client+- Assign index numbers to actors from continued teams+- Add continued team character counter+- Generalize hero gear to each team with continuity+- Store team continuity in a faction+- Add team continuity across scenarios to content+- Add persistent sheroGear to server state+- Add a comment about why aspects of meta game items are not preserved+- Keep flavour of MetaGame items between games+- Keep identity of MetaGame items between games+- Simplify and speed up serverDiscos+- Add a flag to keep item identified between games+- Make sure pushed actors never hit before flying away+- Use lookupActorTime instead of manually inlining+- Only activate the first effect with UnderRanged and UnderMelee+- Simplify deflection descriptions given they don't stack in practice, after all+- Describe the new challenges in the manual+- Implement disabled flinging challenge+- Implement disabled crafting challenge+- Add two more challenges+- Display tutorial hint only for bad temporary conditions+- Let AI use items with -1 speed, e.g., shields+- Improve valuing of SkDeflectRanged and SkDeflectMelee+- Try not to recompile dependencies between cabal-plan and LambdaHack+- Try to work around packages not updated for GHC 9.0.1+- Add deflection temporary conditions+- Add GHC 9.0.1 to travis and .cabal+- Implement skills for ranged and melee invulnerability+- Add skills for ranged and melee invulnerability+- Implement flags for applying when under attack+- Add flags for auto-activation when under attack+- Let AI with low skill target suspect terrain+- Prevent AI from trying to trigger blocked tiles+- Explain why we crop surface, not texture, even for prop font+- Explain the pointman/leader discrepancy+- Gut out the last remain of 'cabal list-bin'+- Add some list-bin debug to travis script+- Explain away a text rendering artifact+- Make sure speaking unique messages are not ignored+- Don't interrupt for taunt messages+- Move the tutorial hint about hearing taunts to the correct place+- Add tutorial hints about taking damage+- Only save to log any interruptible messages while in melee+- Add some more tutorial hint messages+- Write key names as on the keyboard, button names as in the button+- When leader stands over an item, say so, not 'notices item'+- Unify pluralization of skills and challenges+- Add some tutorial hint messages+- Add the first tutorial hint+- Start with tutorial hints, but not in screensaver mode+- Ignore tutorial hints, as needed+- Give a more informative message when detecting that AI stuck+- Move tutorial hint options from state to session because they are UI-only+- Keep the tutorial override option from game to game+- Implement the convenience option to override tutorial hint display+- Add a convenience option to override tutorial hint display+- Set tutorial messages according to game mode+- Toggle tutorial messages when starting a game+- Mark some game modes as tutorials+- Display manual at the end of help+- Keep the rest of the manual in content+- Split manual into paragraphs aware of some markdown formatting+- Simplify an address in manual not to spill over 80 columns+- Make duplicate errors more informative (fixes #204)+- Factor out movementDefinitions+- Hint in config file to disable the special movement keys+- Hint that stealth if possible and AI vs player symmetric+- Save after game over, to preserve history+- Limit mentions of 'playing' not to break immersion+- Delimit with colour the known endings section of F1 screen+- Change 'scenario' to 'adventure' to be more immersive+- Dedupe special item and lore menu overlay handling+- Strenghten the types in item and lore menu code+- Display scenario lore (fixes #157)+- Factor our scenario description code+- Mention that scale needs to be configured for high dpi displays, see #164+- Shorten some travis tests+- Make full map position info mode the default+- Refer to the inspected map position as 'here', not 'there'+- Use the actor pronoun when describing items at the same position (fixes #215)+- Don't switch the subject from enemy actor to self for the same map position+- Don't chain dependent sentences when examining map position+- Improve the wording of actor blurbs when inspecting map postions+- When inspecting map locations, make items subjects (see #215)+- Make it more obvious the game outcomes are fixed terms+- Compute BFS with Word16, not Word8; slower, but some paths are longs+- Be more careful avoiding 32bit overflows in frequencies (for JS)+- Don't interpret the common desktop-switching key combinations+- Clear the margins also when redrawing after viewpane changed+- Specify fullscreen in config file and override on commandline+- Implement both kinds of fullscreen+- Name variable same as record field+- Remove help comment regarding SDL-only+- Add fullscreen CLI option for SDL renderer+- Indent by 4, not 2, proportional spaces+- Disable brew-sdl2-osx in travis that now takes too long+- Don't configure the unused data directories when invoking cabal+- When installing don't create the now empty GameDefinition/fonts/+- Don't limit jobs to 1 now that cabal shows errors fine+- Don't embed the fonts in the web frontend version+- Get rid of datafiles from .cabal+- Kill the font license files that are duplicated in COPYLEFT file+- Get rid of the now unused fontDir option+- Use embedded fonts, unless absolute path is given+- Embed game-supplied font files+- Try to be more verbose where running cabal test in appveyor+- Don't create ~/.test directory when testing+- Version config file; fixes #220+- Don't error out if the effect-causing item is not seen by strangers+- Add assertionz that, normally, items are known by actors affected by them+- Hardwire a few less colours+- Mention the item responsible for an effect, unless spammy+- Get rid of a left over no-repetition message helper+- Pass on the item responsible for an effect+- Start main menus at the first normal item+- Open game homepage when clicked in Main Menu+- Write the homepage address in full in Main Menu+- Depend on open-browser package+- Make the game over messages more colourful; fixes #213+- Tweak the display of game over messages+- Make one kind of ending message more precise and colourful+- Display camped and restarted endings in F1 scenario screen+- Save which games are camped or restarted+- Add default messages for Restart and Camping; fixes #212+- Sort outcome constructors for best display in F1 scenario screen+- Colour only outcome name in game over header+- Refactor renderSection in preparation of multi-color lines+- Avoid 'restart in foggy mode'+- Unify rendering of game outcomes; fixes #210+- Remove a leftover mention of rmainMenuArt+- Improve the colours of the F1 scenario description screen+- Expose the meaning of colours for the use in other modules+- Specify also defeat endings+- Make headers in F1 scenario screen monospace+- Factor out attrLinesToFontMap+- Render F1 scenario screen better; fixes #208+- Add tests for many game modes in one session; fixes #228+- Add slowCrawl make target to observe AI in detail+- Mention in item description it's unique, because name may not underscore it+- Ignore the placeholder messages when displaying one message+- Don't overwrite prop with mono overlay even if the latter empty+- Add placeholders to history display, fixing #236+- Add a comment about historyMax divisible by screenful+- Improve message class of HP-affecting effects display+- Mark with dots if the show distinct messages different than the longer+- Implement distinct messages for becoming more affected by a condition+- Implement distinct messages for SfxTimerExtended+- Move messages that are hard to scrap to Distinct class, to fix it+- Prepare ppSfxMsg for Distinct messages+- Don't let ESC clear messages in aiming mode; was confusing+- Add Discord and Matrix addresses to the manual+- Add links to discord and matrix chat+- Let MsgRunStopReason suffice for running interruption+- Save spam, but don't show+- Clean up scraping messages+- Don't run if ordered to run into solid tile+- Reword the short post-action messages+- Don't show both terrain description and a warning about it in yellow+- Typeset one line of history view the same as whole history+- Make some messages longer to look better on a separate line+- Reverse history to match the order of messages shown on screen normally+- No longer specify initial repetition of a message+- Eliminate not saving and not repeating messages using counts+- Use allB in a couple more asserts+- Assert message constructors have proper length+- Get rid of message class GADT as designed by Alex Byaly, simplifying code+- Wrap first line of overlay at half the screen, not earlier+- Make indentSplitAttrString more accurate+- Tweak unique entities in content, adding 'the' as needed; fixes #214+- Don't capitalize and add 'the' to unique entities+- Be more verbose when displacing over laying items+- Align single high score lines+- Copy-paste-hacked enlarging line-wrap treshold if too long headers then fit+- Fine-tune display of too long reports+- Display message classes aligned+- Rename message class constructors for better display+- Display message class in grey+- Indent wrapped messages+- In messages, replace some magenta risks by bright red harms+- Be careful measuring length of multi-line texts for wrapping+- Use the config option for one message per line on screen+- Hide the implementation of Msg, again+- Display message class in history if one per line+- Don't report HP changes of projectiles+- Use the config option for one message per line in history+- Pass along the config option for one message per line in history+- Add config options for one message per line+- Rename the item spotting message+- Bring back filtering empty messages, to fix checking if report empty+- Add Show instance to history and its components for debugging+- Improve removing EOLs when deduplicating messages+- Remove MsgItemMoveLog now that one message class suffices for two components+- Get rid of isSavedToHistory and isDisplayed encoded now in the GADT+- Customize messages more comfortably+- Simplify restarting client+- Remove the code enabling multiple UI clients+- Don't spawn many UI clients, but re-assign a single one+- Make MsgClass a GADT+- Eliminate Binary instance of MsgClass in preparation of GADT+- In config file, specify prefixes of message class names+- Change colour of game start message to a nicer one+- Issue special messages when actor fall to sleep or wake up+- Tweak message class use and colour assignment again+- Remove abuse of MsgTileDisco+- Recolour enemy spotted animation according to colour meaning table+- Redo colour assignment to messages+- Update frontends to highlight changes+- Change the colour of names of sleeping actors to blue+- Reflect changes in highlighting in the manual+- Swap blue and green highlights+- Highlight dominated actors more distinctly, as proposed by @bulbousBullfrog+- Rename confusing message classes+- Make sure indented texts are wrapped at earlier position+- Make most texts wrap before full screen width+- Extend UI.Content.Screen validation+- Tweak texts to fit on screen easily with square font+- Permit wrapping messages after N columns+- Prefer stairs in bottom right corners to leave space for messages+- Prefer levels in bottom right corners to leave space for messages+- Update documentation to the config changes+- Prevent friendly AI from wasting time nosing around our stash+- Rename an identifier to a consistent form+- Limit the size of monospace prompts when keypress requested+- Redo message colours given that some colours get a very thin font, possibly+- Use a mixture of fonts in the challenges menu+- Comment the config file some more+- Render all titles in mono font+- Typeset mouse command table in varied font+- Gut out Ubuntu Family Fonts from Debian package, because non-free+- Beautify CREDITS+- Rand the fontsets differently+- Make the fontset tests more random+- Don't run noopt travis tests on normal length crawl+- Test all fontsets+- Extend client logging+- Make the game reentrant+- Prevent mangled newlines in concurrent screen writes+- Permit text usage in tests+- Refactor mkUIOptions to require less content+- Settile on 'auxiliary fonts' instead of 'long text'+- Hardwire GTK font size to fix breakage from config format change+- Simplify FontSetup+- Implement scaling all fonts easily and safely+- Add font scaling option to config and commandline+- Prevent overspill when prop font is, in fact, mono+- Remove the now unused portions of config and commandline+- Make getFontSetup more accurate (not used yet)+- Eliminate really the last dependency on old config file fields+- Add a comment about lack of optimization for duplicated fonts+- Eliminate one last dependency on old config file fields+- Hardwire the font families to use for GTK frontend+- Use the two weights of prop font+- Recover old SDL frontend functionality using new config+- Move font types to make importing them in ClientOptions legal+- Let fontset be chosen on commandline as well+- Extend config file with font and fontset definitions+- Molify Debian's lintian+- Legalize all the long text fonts even more+- Legalize all the long text fonts+- Add the ubuntu font family set of long text fonts+- Add another set of long text fonts+- Add new long text fonts based Adobe Source+- Remove old long text fonts+- Add commented out TTF.setHinting directive+- Crop too high fonts more at the top than bottom+- Get rid of the last traces of 'exploiting' terrain+- Simplify and speed up linearInterpolation (not benchmarked)+- Change which test is run in -O0 travis+- Make final version of integer casts hardening, using the type-level int-cast+- Explain the communication overhead concept+- Use toIntegralSized to crash when int wrap would occur during conversion+- Parse config at compile time+- Let foes occupiy exit in escape scenario, etc.+- Add missing cskip specifications+- If more info in history, end message with three dots+- Bump GHC versions for testing+- Bring back SPACE as clearning messages+- Update the default config wrt changes to RET keybinding+- Let ESC cancel the aiming line as well+- Keep the order, modulo abs, of factions as in the roster+- Don't switch level away from melee when positions not taken yet+- Improve valuing AI displace action a bit+- Increase expressiveness of initial actor generation+- Permit tiny rooms if no stairs variety+- Pick the sole actor for cwolf games ignoring empty specs+- Remove length that forces the whole psFree, even though most unused+- Don't drop initial actors if not enough initial faction positions+- Remove a code check that is already in mode content check+- Generate initial actors in the order given in content+- Prepare types for more faithful initial actor generation+- Rename ES.toList+- Simplify populateDungeon and catch similar overcomplications+- Generate initial actors in per-faction positions, not in alliances+- Make the use of integral conversion easier to verify+- Reword ESC description again+- Settle on apostrophes to denote one-letter keyboard keys+- Update command docs to command help changes+- Let only ESC clear messages+- Show newcomer aim mode help also when pressing ? in non-default detail level+- Simplify how the hint prompt works+- Align newcomer aiming help with ? help when aiming+- Try harder to display errors in appveyor runs+- Simplify and slightly fix linearInterpolation+- Extend debug information when summoning fails for lack of space+- Except for DetailLow, always show any description when examining+- Give feedback of detail level also when item selected+- Show item symbol in item lore view in square font+- Tweak and fix item examination messages one last time+- Change display of terrain more gradually as detail level rises+- Simplify two cases of sortBy emulating sortOn performance-wise+- Improve describing of items with words limit 1+- Use partItemWsDetail for item description when examining+- Make the second detail level the default+- Fine-tune shortest item examination message once more+- Move SPACE to CmdAim category+- Document that MMB and RMB cycle detail level+- Let RMB and MMB cycle detail level+- Add aiming help line for newcomers with SPACE hint+- Don't warn about our own actors+- Reformat lookAtActors+- Implement detail level for actor descriptions at position+- Show position description components according to detail level+- Show detail level in HUD+- Redraw after detail level changed+- Implement detail level for item descriptions at position+- Match the new order of descriptions in a couple more places+- Bind SPACE to cycle detail level in aiming mode+- Add DetailCycle human command+- Record detail level in the aiming mode state+- Add and improve headers for scenario endings messages+- Change sortBy to sortOn in a couple of places+- Optimize truncateOverlay with the best of the sortOn and sortBy worlds+- Replace some performance-wise wrong uses of sortOn with sortBy+- Mark the last major outcome in F1 scenario screen+- Change unique actor names to match the upcoming new convention+- Don't show even deafeat messages in F1 if not experienced+- Update the '?' hints to the new Tab semantics+- Add dumping history to a text file+- Advise to replay initial scenarios+- Adjust the order of spotting to match the order when exploring+- Swap the order of intrusion warning and enemy spotted message+- Announce specially foes that have non-trivial items equipped+- Clean up Content.Input.makeData+- Destroy the trunk when actor dies, for death effects+- Make sure embedded item desc stands out from the following activation info+- Make unique speech heard regardless of distance+- Let uniques taunt in a big way+- Add type signatures to AI action picking functions+- Reorder consistenly mode kind component definitions in the file+- Extend rarity specs to above 10 logical levels+- Improve comments and messages about Rarity datatype+- Avoid spoiling victory game over messges, until seen+- Factor out victoryOutcomes+- Display game over messages in F1 scenario screen+- Shorten a field name to avoid >80 length lines+- Colour header in the F1 scenario screen+- Disable a travis test that still panics+- Revert the scenario choice font frop prop to mono, for typographic consistency+- Shorten a flavour blurb to make it fit when font is square+- Extend wrong line break avoidance to colourful texts+- Display also flavour in scenario choice screen+- Don't attempt to display F1 scenario blurb in square fonts with two columns+- Don't display the extra TAB commands in item menu headers+- Mention the new TAB commands in manual and keys sheet+- Represent a key not appearing in help by empty categories, not CmdNoHelp+- Enable pointman cycling key bindings with Control+- Factor out the pointman cycling key bindings+- Make sure item spotting messages are of proper length+- When spotting new items, write short message to screen and long to history+- Don't merge messages with different classes+- Enable messages that are not displayed unless from history+- When spotting items, sort them only once+- Don't report each item located in stash in a separate sentence+- Add verbosity flag to UpdSpotItemBag and UpdLoseItemBag+- Make new Direction type more general so that it can be used in other cases+- Add direction type to make cycle function less verbose+- Add functionality of back-tabbing both across floors and within single levels+- Add bool flag to cyclying so that direction will be possible+- Change naming of member cycling in-code to be keypress agnostic+- Swap S-Tab for A-Tab as new binding for cycling members on the same level+- Swap descriptions in help file so that tab functionality matches description+- Swap funcionality of Tab and S-Tab without renaming in-code+- Reverse order of S-Tab so that it doesn't first cycle to another level+- Add up to two EOLs in tile examination message+- Order tile examination message elements by decreasing importance+- Make terrain names harder to confuse with items+- Improve messages and order of stores when moving items+- Make ItemNotCalm message applicable to flinging and triggering, too+- Tighten the result type of moveItems+- Add a comment to the default config with an example for rebinding a key+- Clarify that nominal values of burning and wounding are used+- Don't call robots living+- Don't display TMI about total condition time if come from explosions+- Let AI prefer a buckler over a fist+- Nag about the F1 screen when starting or resuming+- Display info about scenario in F1 screen+- Split mode note into motivation and hints to choose where text is displayed+- Restructure text displayed on challenge menu to make it more clear+- Add scenario rule notes to be displayed instead of full notes+- Don't let crosshair obscure terrain, items and actors+- Work around SDL treating tilde as paragraph on some Mac keyboards+- Speed up DOM rendering by ignoring highlights if possible+- Permit specifying seeds in the config file+- Make attacking animation more subtle to distinguish from harm animation+- Even in the subtle hit animation indicate who is the victim+- Add a missing space between 'modify terrain stat' and '5' with square font+- Make Burn as valuable as other damage for consistent UI display+- Show very good no-timeouts weapons at the correct position+- Partially hash-cons ItemQuant, with very modest effect+- Change some occurences of trivial Quant to quantSingle+- Simplify skill and place menu code+- Don't multiply initialPlaces when preparing place display+- Consume places for places menu more eagerly+- Eliminate space leak when creating items+- Avoid memory leak due to caves used for levels on a list+- Fit the short help blurb in 4 lines+- Start the game with a confirmation prompt+- Sort weapons wrt timeout and item kinds ID as well+- Simplify querying skills of the leader+- Avoid long animations before the extra burn or wound animations+- Change combat animations to easily distinguish attacker from attacked+- Let AI displace teammates when no risk of displacing back+- Restrict AI use of stash guards less harshly+- Add a comment about allies stealing each other's stashes+- Let AI keep fleeing if no support gained+- Remove a few redundant TypeFamilies pragmas+- Explain in a comment why on a level with stash many sleeping may accumulate+- Make safari scenario harder now that aliens are buffed up+- Let AI displace friends less often+- Unify the test for item being damaging+- Improve module haddocs for content+- Hide unneeded content group name patterns+- Add short-caves debug game mode+- Display melee damage even if there's no ranged damage+- Reduce the number of calls to foeRegularAssocs+- Make sure AI actions are not recursive, even shallowly+- Reduce the number of calls to currentSkillsClient+- Speed up skill arithmetic+- Math order of cases in processWatchfulness with the order in type definition+- Remove inlines that stopped helping in GHC 8.8 and that obstruct profiling+- Compute friendAssocs only once for each actor AI processing+- Limit and speed up invalidating BFS+- Speed up a few significantly expensive functions+- Use the JS splitmix optimization+- Tweak random numbers code a bit+- Improve haddocks of the dice mechanism+- Improve help display a bit+- Move ClientOptions.hs to adhere to the convention about module hierarchies+- Meld LH and Allure content, continued+- Port over oil explosions that harm the targeted actor from Allure+- Meld LH and Allure cave and item content+- State the number of item in equipment even when removing from it+- Explain the goofy handling of recharging in stash+- Regenerate tile even if kind not changed, but all embeds gone+- Permit altering tiles with items on them+- Don't leave stash unguarded if friends may spawn+- Add stash detection effect+- Cap stat bonuses when assigning AI value to items+- Value skill bonuses differently for each skill+- Be even more specific when describing what an actor does on a tile+- Adjust the SDL test to run without installing fonts, as Debian requires+- Don't let projectiles ever cause normal tile transitions+- Tweak pushing via an embed+- Add Q&A about hearing+- Tweak item valuations to make awkward armours wearable by AI+- When describing an actor, say if it's pushed+- Push towards embed, not in direction of previous movement+- Simplify key bindings display code+- Clean up naming of column offset in UI+- Ensure no missing space between columns of help text+- Prevent a trailing space+- Don't activate barrels via mist+- Don't treat blasts that damage through effects as mists+- Don't let on noise distance if nobody can hear it directly+- Differentiate the sound of projectile and actor hitting a tile+- Emit sound also when an actor hits a tile+- Display close and out-of-level noises with special colours+- Display noise distance information+- Send noise distance information+- Refactor hearing+- Mock up extended hearing+- Give better message when not enough skill to melee+- Disturb resting when calm enough again+- Don't summon by hitting a projectile+- Make actor aggresive if only one is not guarding stash on the level+- Ban teleporting immobile foes; they come back and their loot is lost+- Validate that item group names are short enough+- Cath too long group names+- Catch empty group names+- Let more actors start sleeping+- Consistently create on the ground all items looted from terrain+- Mark game modes already won in this difficulty+- Clear screen after start ASAP+- Use the AttrLine smart constructor or assertions as appropriate+- Rename firstParagraph+- Tweak types to work with the stricter smart constructor+- Move assertion about trailing whitespace to a smart constructor+- Eliminate trailing spaces in help and item menus+- Replace a momentarily trailing space with nbsp+- Don't define special messages with space, they are added automatically+- When splitting lines, remove the trailing spaces+- Simplify a condition in splitAttrPhrase+- Don't add a space when appending a report that starts with newline+- Don't produce backdrop on black background+- Optimize truncateAttrLine and truncateOverlay+- Mark assertions expensive in menus+- Make avoiding SDL frame drawing more fine-grained+- Simplify SDL frame drawing based on previous frame+- Optimize menu scrolling via an extra texture+- Don't waste healing items when HP low ceiling+- Don't display that foes don't know their weapon when only you don't+- Reflect keybindings change in the start scenario menu+- Permit hero AI to consume elixirs+- Don't flee if can kill a blocking enemy instead+- Make fast or hasted actors willing to close in for melee+- Compensate for overhead of animals when creating conditions+- Mark organs that are ready to expire once applyPeriodicLevel runs+- Avoid stating that an organ will last for 0s+- Tweak slightly AI item preferences+- Get rid of DropBestWeapon+- Don't rechare nor discharge projecile payloads+- Start dicharging with strongest weapons+- Let Discharge add to cooldown, not reset+- Discharge only items with a timeout+- Consider as support only actors that can harm in melee+- Make organs (minimally) accessible from triggering+- Let AI trigger items among organs+- Relax trigger stat 1 restrictions+- Tweak AI item use preferences valuation+- Improve the gameover item menu message+- Record duplication of items to avoid absurd gameover messages+- Discharge not only equipment, but also organs+- Don't paralyse the last AI stash guard+- Give AI stash guard more freedom if friends adjacent+- Make AI keep guarding even if teammates on the level may leave it+- Don't let AI leave stash unless foes harm it+- Don't abandon stash when teammates temporarily immobile+- Prevent displacing a stash guard+- Don't abandon stash if temporarily nonmoving+- Abandon stash if under heavy fire+- Don't abandon stash unless foes seen+- Don't use aidTgtToPos unless necessary+- If enemy in light, pelt him instead of leaving dark+- Don't stop fleeing into hideout after 5 turns even if foes appear+- Target dark if fleeing and no foes targetted+- Efficiently find closest hideout for AI+- Tabulate hideout tiles predicate+- Factor out distanceBfs+- Don't hog leadership just because weak and enemies close+- When fleeing and soon after target only actors that can't melee+- Stop fleeing if not hit and possibly friends managed to join+- Take into account recent fleeing when taking off light+- Simplify hinders+- In AI action choice use recent fleeing instead of this and last turn distress+- Don't overwrite fleeing record if fled recently+- Don't chase foes if fled recently+- GC fleeing record when actor lost+- Extend fleeing state from 1 to 5 turns+- Store not only fleeing position but also fleeing start time+- Reorder organs+- Make two organs not LH-specific+- Don't undervalue weapons with drop condition+- Make it possible for animals to mark levels as explored+- Make slack tactics AI less erratic when focused or distressed+- Add a comment about animals bad at changing levels+- Let AI displace any sleeping blockers+- Don't let AI actors fall asleep if not relaxed+- Don't force animals to change target just before reaching it+- Improve condAimCrucialM for vector targets+- Flesh out the crawl survival test scenario+- Make crafting act as if on bottom level+- Move skill checks from pathfinding to targetting and restrict immovable actors+- Forbid making missiles hungry, asleep, etc.+- Optimize processTileActions+- Make sure projectiles can modify terrain even if safe from effects+- Don't reset TVector target, because it's set manually+- Create a central staircase+- Display ranged damage even when limited space in menu line+- Shorten the display of weapons if not enough space+- Don't consider enemy projectiles for determining if AI is in melee+- Make poison less deadly in corridors+- Eliminate the stash domination exploit+- Make guessing if AI was hit by projectiles more accurate+- Prevent wounded animals from closing in agains mutliple enemies+- In messages tell discharge from recharge effects+- Make smell more important that stairs, again+- Clean up vector target code+- Melee non-targets if target not worth killing+- Don't perform all monadic actions that compute strategies before choosing one+- Don't retarget actor if blocked by the very actor and so can melee it+- Simplify target shoice for slack doctrine factions+- Sort items in lists in normal texts+- Help AI unlock the dungeon if stash guard helds the key+- Prevent animals from eating their own meat+- Prevent creating new items via throwing others, with ikit+- Signal specially when an item is located in a stash, as well+- Say when an item appears in a stash, etc.+- Don't warn if selected missile from stash can't be picked up+- Don't flee if back next turn+- When fleeing don't remember the last targetted enemy+- Move keybinding content definitions to match display order+- Prevent, in UI, removing from equipment if not calm+- Warn when illegal item movement attempted+- Display stash blurb also when switching the leader+- Don't let stash guards leave levels+- Don't prevent displacing a friend if only half of a loop is present+- Don't neglect guarding stash unless no buddies to help+- Tweak AI conditions+- Don't flee if own stash close unless completely overwhelmed+- Easily displace teammates that guard the stash+- Mention stash when walking over a tile+- Do not flee and be reluctant to chase when guarding stash+- Introduce guarding own stash+- Make isDoor more accurate+- Don't make a rumble when door closes+- Tabulate isOpenable and isClosable+- Make tall staircases more likely now that they are often broken+- Make types a bit more strict in stairs calculation+- Simplify stair number computation+- Rename cextraStairs+- Change the semantics of cextraStairs+- Separate stair number computation and level generation+- Compute abandoned stairs earlier+- Correct the documentation of cextraStairs+- Roll extra stairs earlier+- Roll cave kinds earlier+- Simplify shuffling caves+- When transforming walkable tiles, don't insist on embed activations+- Ban crafting and terrain transformation in the same action+- Try to make the terrain transformation specs more readable+- Prevent the exploit of using cover against non-moving shooters+- Make makeLine non-monadic+- Keep the data invariant of @arenas@ for longer+- Make the *interrupted* running display look less corrupted+- Add and tweak comments about item maps+- Update the manual and keybindings printout+- Tweak the wording of keybidings descriptions+- Prevent marking inert items as (charging)+- Add ANY_FLASK group+- Make sure impression is dropped before other conditions+- Handle failed bump-modification without embed activation+- Change the key for new game, not to mix up with 'n'o+- Remove misleading comment about tiles being explorable+- In message fits in one long line, don't wrap it into small lines+- Don't make consumables with Ascend effect worthless+- Change division by zero into an assertion failure+- Comment why 'seen' sometimes gets from 100% to 99%+- Validate HideAs in content instead of asserting its property later on+- Tweak (speedup the tiniest bit) updAlterTile+- Stop leader before leaving dark in a more useful way+- Don't equip light even if enemy only remembered+- Simplify the interesting target conditions for AI+- Flee through dark not only when starting in light+- Chase and flee through dark even if not starting from light+- Simplify the chasing ambient light condition+- Prefer leaders that don't step into light+- Detour when chasing, to avoid lit spots+- Prefer fleeing into dark spots+- Don't flee from projectiles if can't flee into the dark+- Prevent AI from vainly chasing fast shooters+- Tweak and simplify AI fleeing condition+- Help AI sidestep a blocking meleeing friend+- Let AI go towards enemy stash even if in melee+- Join melee from twice longer distance+- Rename CURIOUS_ITEM+- Don't display 0 ranged damages+- Add missing content group definitions+- Simplify content validation+- Check that content group names are all listed+- Let the draft detector emit noise and sound+- Tweak the engine to accomodate a detection device that pings+- Prevent non-humans from hogging key items and so blocking progress+- Reorder item definition to match those of Allure for diffing+- Don't emit server leader change messages if known to client+- Comment about the trade-offs of weapon benefit calculation+- Mark the lore screen with crafting recipes+- Don't confusingly refuse to display the pushing effect for shields+- Increase minimal damage taken, regardless of armor, to 5%+- Be pendantic when emitting messages about creating items+- Don't say that a projectile is wounded+- Show enemy HP under the selected item+- Simplify strongestMelee+- Add an alias for picking up all items, etc.+- Sort out naming of item and embed activations+- Simplify revCmdMap+- Warn when embeds activated, but transformation failed+- Check dangerous tools use even when nested in transformations+- Don't transform terrain when bumping+- Let pathfinding avoid vicinity of enemies+- Make it easy to discern an attack on teammate among many messages+- Don't display misleading condition drop messages+- Visually distinguish embed names and descriptions+- Permit fractional FPS, for debugging+- Colour-code map position descriptions+- Move the run macro to where all other engine macros are defined+- Permit unknown command, for testing+- Simplify and clarify the mock+- Unify repeatHumanTransition 1 and macroHumanTransition+- Reflect in types that macro frame stack is never empty+- Make more space for explicit import lists+- Rename components of the macro data structure+- Drive the point home that repeatHumanTransition 1 /= macroHumanTransition+- Add tests that illustrate not creating new buffers for in-game macros+- Touch up the macro code a bit+- Add tests showing lack of referential transparency of named macros+- Don't prompt about recording a macro it's part of macro replay+- Warn when pick up not to equipment due to low calm+- Display how many items in equipment when equipping+- Refuse to equip if equipment full+- Separate testing harness import from game content import+- Add a helper function to shorten tests+- Rename the semantics functions+- Implement the desired semantics of RepeatLast+- Sketch the desired semantics of RepeatLast via tests+- Use the same updateLastAction function in test mock+- Collect a more precise last action key+- Simplify slightly the mock+- Grey out more (all?) illegal commands+- Add special messages when illegally flinging or applying+- Go even through stores that all factions have empty+- Revert banning stores for all actors based on the first checked+- Add special messages when illegally moving items from or to eqp or ground+- Forbid unequipping items when not calm, again+- Don't ignore illegal stores if once shown+- Display the number of items in equipment even when not calm+- Write client RNG seed to UI RNG seed numbers at game restart+- Save UI random seed to avoid boring messages if many save/loads+- Add a comment about stealth viable for tactics, but not strategy+- Reset C-f when x-hair automatically changed+- Pick as leaders also the actors that could melee but should not+- Make animals unable to catch projectiles+- Don't cycle xhair through own stash+- Display slideshows normall unless really too long, not just excessively long+- Give more time to view a frame when frame level changes+- Be more verbose when kicking terrain+- Prevent the inability of taking off max calm draining items+- Re-assign action repeating keys+- Clean up macro command's texts+- Place ikit item in a semi-random way+- Tweak content group names for display+- Avoid 'of gain of gain' in item descriptions+- Don't talk about blocking when no kinetic damage dealt+- Match the order of game over lore screens with in-game lore menu+- Prevent AI from imbibing a potion of panic+- Don't call a tile alterable if embeds have no effects+- Prefer leaders that target enemy stashes+- Don't chase stashes of friends and neutrals+- When creating items on the floor during dungeon generation, create ikit items+- When embedding items in tiles, optionally generate more items+- Redesign so that charging items can be determined even if timeout unknown+- Clean up some instance deriving+- Factor out two more pure functions about macros to use in unit tests+- Permit creation of input content without parsing a config file+- Factor out pure function about macros to use in unit tests+- Record nested macros on stack+- Snatch enemy stash ASAP if adjacent+- Port tests to tasty+- Undo the attempt to end game when player kills window+- Remove a spurious recordHistory+- Make sure verifyCaches error doesn't obscure RNG seed of the crashing run+- Don't let big actors auto-craft at death+- In menus show how long conditions will last+- Tell how for long an actor is going to be slowed when first affected+- Tell how for long an actor is slowed in total after extra slowness, etc.+- Tell how much poisoned actor is in total after extra poison, etc.+- Don't display the mandatory turn frame if a frame already displayed this turn+- Don't draw (and printscreen) identical frames, even if small fonts used+- Don't trigger terrain if projectile has lost its payload+- Enable cooking of food thrown into fire+- Don't spam when blasts transform terrain+- Simplify dieSer+- Ensure the last step of projectile flight is shown+- Remove a repeated check+- Be more verbose when transforming items with scrolls+- Display level where the stash is, as a reminder+- Don't displace sleeping immobile actors+- Simplify checking if an item is identified+- Prevent AI from putting most weapons in reserve+- Let AI be eager to equip unidentified and good unique items+- Don't be too verbose with tile altering when leader stands on it+- Don't craft from equipment due to possible involuntary harm+- Remove altering via dropping items; too disaster-prone+- Refactor handleDir+- Permit indicating the zero vector with mouse+- Colour and reword the message about consuming items+- Be a bit more verbose about tile changes+- Don't inform about a projectile's equipment+- Avoid hitting 'feebly' with a heavy hammer+- Show, e.g., harpoon as an obvious choice for throwing despite usable for melee+- Don't summon by hitting a friend+- Don't hit delicately just because the weapon was not identified+- Prevent AI from wasting time throwing very weak projectiles+- Avoid 'chip of scientific explanation turns out to be', when identifying+- Improve item destruction messages+- Add OnUser effect constructor+- Avoid 'the pair turns out to be' when identifying+- When short name requested, don't append numbers and parens+- Prevent VerbMsgFail being repeated 99 times+- Describe how colours correspond to tile properties+- Let even unskilled actors take over stash+- Take over stash also when actor dominated or created+- Target enemy stash in preference even to enemy actors+- Add comments about salter and pathfinding+- Avoid 'controlled by Controlled foo'+- Avoid 'hits delicately' with a 14 HP wounding hammer+- Ensure in content that Burn is positive+- Mark weapon burning and wounding on HUD, to avoid hammers all look benign+- Clarify that chosen weapon needs not be optimal for a foe+- Improve display of places lore+- Pick up enemy summoning periodic items to deny them to foes+- Don't send the SfxTrigger messages to the client+- Mention that stats menu summarizes the organ menu+- Add sample cabal.project.local files+- Introduce VerbMsgFail effect+- Let crafting use up terrain, if successful+- Don't split tile properties description by description of things on the tile+- Avoid crafting via walking into a worshop tile+- Introduce SeqEffect to use for crafting creation in place of AndEffect+- Let components 'disappear', not 'be removed' during crafting+- Improve crafting recipe description+- Automatically identify crafted items+- When cratfing, use tools but destroy components+- Don't create items in equipment if not enough free slots+- When crafting, apply as many copies of durable items as required, not just one+- Don't crash if crafting fails due to unique already generated+- Improve debugging of item creation+- Don't display thrown damage for organs+- Flesh out projectiles opening terrain and flying through+- Require embed activation even for item-fueled terrain transformations+- Don't spam if recording is a part of a macro+- Make the summary of killed enemies less confusing+- Let some explosions destroy terrain+- Add black backdrop beneath prop font overlays, for readability+- Be even less verbose in descriptions of items with crafting+- Validate that item definitions have slots whenever expected+- Rename the Macro type+- Record also in-game menu navigation keys+- Recover macro's recording order invariant+- Document Macro, swap types in smacroBuffer's Either type+- Wrap the macro buffer into a newtype+- Encode recording state in type of macro buffer+- Be more precise when reporting OnCombine effects+- Format crafting recipes in a more readable way+- Gather effects application flags into one record, for redability+- Add an assertion that catches ItemQuant data invariant violation+- Ignore timeouts when using tools or transforming terrain+- Don't apply kinetic damage when using tools or transforming terrain+- Generalize printing crafting recipes to many products+- Rename the dagger item definition to match Allure+- Help parsing recipes with bullets+- Avoid spike 2d1 (cooldown 8) of cooldowns at 4+- Typeset crafting recipes slightly+- Rename the whetstone item definition to match Allure+- Don't repeat crafting recipes in OnCombine descriptions+- Show full crafting recipes only in lore menu, not when targeting+- Speed up and simplify the use of countIidConsumed+- Alter ConsumeItems and unify with ChangeWith+- Add optional count parameter to effect CreateItem+- Validate that item definition parameters in content are positive+- Display details of item crafting effects+- Add ConsumeItems effect+- Let AI ignore potentially unopenable entrances, to avoid AI loops+- Improve messages related to Discharge effect+- Simplify checking actor presence on a level+- Add the Discharge effect+- Be more verbose when loot created+- Don't complain about failed transformation if embedded item triggered+- Revert "Break thrown non-unique items, even if durable"+- Let projectiles trigger only easiest embeds and alterings+- In tile content specify if projectiles may trigger actions+- Display when ending a flight, to make harpoon a sensible weapon+- When actor lacks tools to transform a tile, inform him+- Break thrown non-unique items, even if durable+- Squash repeated terrain transformation tools in descriptions+- Confirm that a weapon is to be used for transformation+- List tools needed for transformation in terrain description+- Factor out client altering conditions+- Unify altering by bumping and altering by pointing and server conditions+- Don't waste turn when altering fails, but waste when embed triggering fails+- Factor out listToolsForAltering and subtractGrpfromBag+- Permit the use of tile altering tools with different durabilities+- Factor out parseTileAction+- Don't count repetitions in OneOf effect description+- Prefer non-durable altering tools, even in equipment+- Avoid message about triggering a 'way' without any more details+- Rename terrain patterns that denote possibly depleted resource+- Consider durable tools last for terrain alteration+- Process tile features in order to prefer trap disarming to triggering+- Prevent embeds triggering each other in a loop+- Simplify applying embeds+- Display untruncated (and mangled) messages in teletype mode+- Make frontendName to avoid losing message in teletype frontend+- Clean up the presentation of group name patterns again+- Verify that singleton group names are so+- Separate singleton kind group names+- Validate that some more kind groups are singletons+- Rename HideAs to PresentAs for item kinds+- Simplify individual content validation due to stronger global validation+- Check that group names unique and not void+- Supply group names to the content creation and validation function+- Improve special gameover messages+- Clean up the lists of hardwired patterns+- Get rid of OVER in pattern names+- Clean up the DEFENSELESS vs VULNERABLE mixup+- Remove foldl from prelude to prevent space leaks+- Group the patterns yet slightly differently+- Catch empty OneOf during item content validation+- Group the patterns slightly differently+- Be consistent in taking only first word as game mode name+- Rename PHD_DEFENSE_QUESTION to VULNERABILITY_BALM for diffing with Allure+- Group TileKind patterns+- Remove IsString instance of GroupName to catch typos+- Reorder code in content files+- Make embed content patterns different from tile patterns+- Use PatternSynonyms for all content+- Permit and use PatternSynonyms in some ItemKind-related code+- Don't crash when some items consumed during dropping+- Don't warn about untriggered embeds; altering may be the focus+- Don't report exploiting if not triggered+- Let terrain be changed with items even when embeds not untriggered+- Be less verbose when losing items+- Be more verbose when losing items due to tile altering+- Report which embedded item was exploited so that 'Nothing happens' makes sense+- Don't report items appearing under projectiles that are already spent+- Reword command category headings+- Don't move away staircase inhabitants if projectile is changing levels+- Let only visible projectiles discover hidden tiles, etc.+- Don't display vacuus menu mode switch symbols+- Waste items for altering only if voluntary or released as projectile+- Get rid of spam about inability to modify terrain+- Identify item lost in order to modify terrain+- Let projectiles alter terrain, but not when just flying over it+- Don't check alter skill when projectiles do the altering+- Improve comments about the 6 tile modifying constructors+- Don't modify terrain by just walking over it+- Permit the use of equipment for modifying terrain+- Warn when no items to modify terrain+- Prefer durable items for altering tiles+- Don't destroy but apply durable items used to alter tiles+- Add tile alteration that demands and consumes items+- Improve description of cooking effects+- Add OrEffect binary constructor+- Replace Composite by a binary constructor+- Display failure message when embed not under feet triggered vacuusly+- Don't light adjacent tiles for free+- Avoid 'you look less hungry' about the pointman+- When smashed item exhibits no effect, don't warn+- Report tile changes under a big actor+- Generally never alter tile if under feet and embed not triggered+- Detect when dropping or destroying items is vacuus+- Only alter tiles via walking on them if any embed triggered+- Don't spam when embed doesn't trigger when walked over+- Implement DestroyItem effect+- Let embedded items react to items dropped over them+- Explain away only pointman moving+- Inform about automatic melee in the in-game help+- Mention that all factions and actors are equal+- Reverse stars and underscores in HP bar in HUD+- Stress suvival in the game manual+- Make skill check for embedded items on the client consistent with server+- Give hints when terrain can't be entered nor modified+- Describe hunger removing items, etc., with more detail+- Mention leap frog in game manual+- When scrapping message repetitions, ignore trailing EOLs+- Don't spam about items underfoot at game start, when they are also 'located'+- Report moving player's stash on a new line, mostly for starting screen+- Bring back scenario notes at game start and resume+- Bring back notes in challenges menu+- Handle the meta note about scenario separately+- Mention challenges in the high score entries+- Remove the Show instance of ScoreRecord+- Invalidate inMelee when weapons dropped or picked up+- Use --assertExplored in makefile tests+- Verify the commandline assertion about explored level+- Don't assert exploration if another game started in a debug run+- Add a debug commandline option to verify explorers are not stuck+- Make projectile-less actors randomly more aggressive+- Add a bit of histeresis when fleeing+- Destroy proportional font textures to avoid freezes when they pile up+- Prevent AI from running away from helpless foe+- Stop targetting foes once they lose all weapons+- Let AI do more vs foe with HP <= 0 to avoid stalemate if foe regenerates fast+- Don't spuriously check if TEnemy is a foe+- Improve documentation of targeting+- Don't attack hapless nonmoving foes at range also+- Don't normally target nonmoving actors that can only melee+- Use actorWorthMelee in inMelee+- Melee a targeted foe even if not worth meleeing otherwise+- Don't target hapless uninteresting foes+- Don't melee a foe with only benign weapons+- Don't consider foes with benign weapons a threat+- Only consider actor in melee if adjacent foes worth meleeing+- Don't interrupt running if benign melee actor adjacent+- Introduce the count of benign weapons of an actor+- Make sure tutorial scenarios have enough melee weapons+- Avoid checking isModifiable once more, in verifyAlters+- Consistently check isModifiable together with embeds+- Mark the new request failures as impossible on the server+- Add some internal operations, for future easier profiling+- Removed TileOpenClosed error message+- Further enhancements in tile closing+- Removed TriggerTile+- Remove commandline default that forced Just that is interpreted as game reset+- Bring back the way dungeon generation perturbed random rolls+- Make 64bit native and 32bit browser games play the same with the same RNG seed+- Keep a separate random seed for UI+- Use bitmaskWithRejection form randomR+- Add some BENCHOPTS+- Use splitmix+- Suggest switching to another teammate if movement skill drained+- Turned off showing of default --maxFps value+- Additional logPriority value and defaultMaxFps+- Couple command line options are now clamped or checked before they're set+- Only run with selected actors that are not yet at goal+- Hint about menus in movement stst too low message+- Hint to wake up if movement skill drained by sleep+- Display also own asleep actors green on HUD+- Make the heading of item menu when inspecting an organ less confusing+- Tell that second 'f' projects+- Add a comment about the 'exploit' verb+- Do not mention 'trunk' in weapon strike messages+- Do not mention 'trunk' in armor blocking messages+- Suggest in history menu to press RET+- Get rid of Server.EndM+- Make sure closing window in rage at defeat/win saves game+- Mention in the manual that HP starts at half max+- Reformat game peculiarities list in the manual+- Don't announce pushing that has no effect+- Try to make the under AI control prefix less confusing+- Let animations be toggled in main menu+- Don't display buttons on a separate line unless message is very long+- Add a newline after scenario description+- Avoid blank lines in history+- Overhaul the order and blurbs of game modes+- Make raid scenario squad-based+- Display scenario descriptions in their submenu+- Don't show backstory in submenus of the main menu+- Rework new game start menus+- Add a visual separator between new games in history+- Reverse the order history messages are displayed in+- Copy the list of distinguishing features from Allure homepage+- Restructure chronologically the game manual with verbs as section titles+- Avoid empty paragraphs+- Ignore linebreaks when showing the condensed history line+- Underline that mouse is optional+- Make 'crosshair' on the status line uniform with other headers+- Bring back the help prompt that doesn't confusingly mention advancing+- Mark overful HP and Calm specially on HUD+- Add some blank lines when stacking command lists+- Stress that mouse is optional+- Move mouse help screens earlier+- Don't indent help parts by proportional space width+- Clarify the structure of help information+- Don't show 'crosshair' when not aiming+- Get rid of 'x-hair'+- Make collective running less prominent in help; tweak help+- Mark some text files as out of date+- Add a paragraph break before nearby item summary+- Accept longer menu messages+- Add a paragraph break before cave description+- Warn that over-max HP gain is transient+- Mark deaths with paragraphs and display 'Alas' already at incapacitation+- Add a line break after gameover identification of items+- Add a couple of line-breaks to reports+- Rename emptyAttrString, which was misleading+- Introduce a newtype of attribute lines with no linebreaks+- Prevent backstory overflow in main menu with proportional font+- Move O command just after I command in help+- When toggling autoplay, as with y/n, not SPACE/ESC+- Let left and right arrow keys move between sides of help screen+- Fine-tune helps screens for display side-by-side+- Naively cram help screens side by side+- Merge the two item command help pages+- Use proportional font for help, dashboard and item menu+- Use square font for movement scheme help paragraph+- Make it possible to use many fonts in help+- Get rid of MoveKeys.txt+- Set up main menu for both proportional and square fonts+- Remove backstory from help screens+- Add backstory to main menu, set up for square font, for now+- With square font, add extra space before item symbol+- Represent button width as a datatype+- Parameterize all typesetting by the font setup (multi or single)+- Pass along information about supported fonts+- Let sdl frontend really handle the setup with no prop nor mono font+- Gut out ascii art+- Add blank space around some lines of overlays+- Take all items with *, not !+- Update the item removal verb+- Switch a single place lore display to mono font+- Render skill menu and item lore menu with proper fonts+- Display item symbol in item menu in square font+- Display label and symbol in items overlay using square fonts+- Display at most 3 lines of buttons when too little space for menu+- Make a mouse misclick error easier to understand+- Don't wrap Mono keys after a prompt+- Overlay in square font when basic frame is under animations+- Introduce a separate UI coordinate system+- Make boxSize even+- Don't highlight wrong overlays when buttons highlighted+- Avoid proportional font in button-like UI areas+- Permit overlays with gaps+- Name font kinds consistently+- Display some overlays in monospace font+- Display history labels in mono font+- Specify fonts also in slideshows+- Move the definitions of DisplayFont and FontOverlayMap+- Propagate the choice of fonts for overlays+- Generalize drawOverlay to specify desired font for each overlay+- Generalize overlays to let them start at arbitrary X offsets+- Eliminate overlayFrameWithLines+- Document better the overlay types+- Move ColorMode to another module+- Specify when to use which kind of main font+- Add monospace rectangular font to game configuration+- Remove the old woff font+- Add new fonts, proportional and monospace+- Specify size of the message font separately+- Don't cursor highlight break up proportional font message chunks+- Don't let space break up prorpotional font message chunks+- Render the extra overlays in proportional font+- If message font supported, pass overlay over instead of rendering+- Initialize also the message font in SDL frontend+- Add message overlay font to game configuration+- Comment about why animals rarely eat food+- Rename tactics to doctrine+- Get rid of the henchman notion+- Rename leader to pointman+- Handle UpdTimeItem when container not visible (CStash), but item visible+- Improve command descriptions+- Redefine key bindings not to collide with new movement keys+- Detect collisions of keybindings with movement keys+- Use the keys freed by removing the right hand movement setup+- Replace right hand with left hand movement keys+- Main inventory the main store in game help and UI+- Move total value display to all posessions menu+- Identify items at any item move, in case they are thrown at stash+- Avoid spam about actors getting braced+- Mention in failure messages that hoard accessed when stading over it+- Mention in failure messages that too low Calm for Eqp+- Attempt to display handling of multiple items more succintly+- Bring back UpdMoveItem to have better messages+- Properly describe item move actions+- Lose access to stash when enemy steps on it+- Say who's stash is an item moved to, unless it's ours+- Announce that enemy stash found+- Make sure to let clients know even the human trinket items at gameover+- Let new stash correctly overwrite old, even if old not seen+- Introduce PosSightLevels and use for CStash containers+- Get rid of seenAtomicGeneralCli+- Simplify handleAndBroadcast+- Make updTimeItem more loose when enemy CStash is considered+- Don't carry item definitions in commands that don't create items+- Register on the client the items necessary for commands+- Analyze what items client needs to know to process a command+- Clean up creation vs spotting of actors and items+- Add UpdRegisterItems to be used instead of many ad-hoc calls currently+- Be permissive when performing atomic action wrt CStash+- Simplify SfxStrike, etc., and don't require access to store's bag+- Simplify PosFidAndSight+- Remove UpdMoveItem atomic command that is not too common without CInv any more+- Simplify handling of CStash action visiblity+- Display also enemy stashes in position description+- Let actors learn stash positions when they come into view+- Mark on the map enemy stashes as well+- Refactor UpdStashFaction to let enemies see it sometimes+- Add shared stash position to team's perception+- Say in position description that stash is there+- Mark own shared stash position with white box+- Remove gstash handling in atomic commands+- Move CStash in server code, not atomic commands+- Avoid catch-all in cmdAtomicSemSer+- Introduce UpdStashFaction+- Do not produce a now unused ItemFull for inventory+- When moving items, don't cycle to Ground, when over stash+- In UI don't try to use CGround when over CStash+- Don't let AI consider floor items at it shared stash location+- When scanning a map, don't consider own stash an ordinary pile of items+- Update atomic position information for shared stash+- Make eqp, not stash, unavailable when low Calm+- Make CStash the new implicit default when picking up items+- Gut out CInv and CSha and replace it with CStash represented on the map+- Remove the unused effect ActivateInv+- Bump version, anticipating major inventory logic overhaul+- Reword the MOwned item dialog mode blurbs+- Simplify the header of the lore menus+- Change meny keys / and ? to > and <+- Update scenario names in the manual+- Mention the ! key whenever KP_* is mentioned+- Simplify and fix placement of --more- prompts+- Change the AttrString word gluing operation and fix drawFrameStatus+- Slightly fix speed calculation to agree with what's on the wiki+- Fix a memory leak from tutorial hints repetition avoidance+- Fix no frames displayed while resting+- Fix missing dot at the end of taunt message+- Fix heroes starting on exit in escape scenario+- Fix the healing necklace better used from the backpack+- Fix which are considered minor effects+- Fix spurious double space suffix when rendring on blank+- Fix mouse in area help, wrongly typeset with square font+- Fix interruption message not appearing on screen, only in history+- Fix wrong order of words in the detection effect message+- Fix and simplify armor conditions message choice+- Fix good conditions displayed in red+- Fix broken combat description condition about armor+- Fix not updated tutorial switch when game won+- Fix a hint wrongly guessing the damage was piercing+- Fix failures not stopping macro playback+- Fix the lack of 'a' when hearing distant summoning+- Fix using the reserved number 0 for faction ID+- Fix backing up broken savegames+- Fix a spurious space before a sentence ending dot+- Fix lack of capitalization in verb messages+- Fix genetic flaw activated at death+- Fix a typo in identifier names+- Fix first lines of message wrapped too late+- Fix botched conditions for SfxFizzles, etc.+- Fix includeMetaGame computed twice+- Fix meta game identification not carrying through to the next game+- Fix accumulating meta game item kinds+- Fix scenarios with numbered actors but without continued team+- Fix an optimization two lines too low in shuffleExcept+- Fix a triple copy-pasto with Ability.MetaGame+- Fix discoMetaGame for clients with state held by server+- Fix displaying deflection when the perpetrator is not seen+- Fix tutorial hints disabling+- Fix a link to roguebasin+- Fix short wrapping of adventure lore+- Fix overflowing messages with more than 2 spaces+- Fix 4 spaces message indentation with square font+- Fix trash on fullscreen borders+- Fix not showing aiming line when changing epsilon+- Fix trying to describe an item that is not seen by the actor hit with it+- Fix whitespace in displayRespSfxAtomicUI+- Fix display of message log aligned to newest message+- Fix extra SPACE needed to see history after game save command+- Fix running broken due to vacuus MsgAtFeetMajor messages+- Fix MsgStopPlayback not stopping running+- Fix usage of two different widths in splitAttrString+- Fix history lines starting with EOL+- Fix monospace overlay whitespace spilling onto proportional+- Fix wrongly enabled display of MsgRunStop message class+- Fix deduplicating shown and saved messages separately+- Fix, again, leftover UI clients killing frontend after already killed+- Fix the numeric display of HP gain/loss+- Fix wrong SDL wrapping markers when using mono fonts only+- Fix a missing mouse command description+- Fix Tasty tests broken by frontend fixes+- Fix screensavers broken by UI faction not being the first+- Fix a bug with two UI clients interspersing frames+- Fix 'open main menu' command of Dashboard+- Fix the GTK frontend again+- Fix a syntax error in travis script+- Fix license name+- Fix linearInterpolation for inflated dungeon depths once more+- Fix running disturbed by many boring tiles at open levels+- Fix MsgItemMove messages not saved to history+- Fix unintentional cap on actor generation level+- Fix calling gameover and 'endgame'+- Fix lack of EOL before initial separation line of history+- Fix mouse coordinates in the browser+- Fix assigning number symbols to hero faction projectiles+- Fix and improve how deflections are displayed+- Fix a 32bit system bug that intCast detected+- Fix damage not displayed when other attributes are+- Fix flinging from item menu cancelling item selection+- Fix the comment about users able to overwrite keys+- Fix a crash when impossible command chosen+- Fix bitrot that corrupted curses frontend+- Fix 'the fallen falling' projectiles+- Fix wrong alignment of level percent seen+- Fix autoexplore with changing crosshair+- Fix goto not interrupted change of crosshair+- Fix the valuation of OnUser effect+- Fix the lack of the last backdrop line in the game greeting blurb+- Fix memory leak in placesFromState+- Fix double braced due the hack for skill-less yelling+- Fix order of using weapons inconsistent with HUD+- Fix actor that can't wait not ignored as a pointman even when inactive+- Fix stash guard preferred as pointman+- Fix AI leader choice to really prefer old leader and to avoid light more+- Fix raid scenario starting with two faction close to escape+- Fix random number out of range on 32bit JS+- Fix teleport effect from stash item not identifying it+- Fix warnings in gtk frontend+- Fix the extra blank menu line starting too late+- Fix section links in the game manual+- Fix and simplify rules for disabling tile transformation+- Fix missed blank prefixes of empty lines inside text+- Fix and simplify projectiles activating and transforming terrain, again+- Fix projectiles not able to lit up oil+- Fix padded empty string overwriting UI elements+- Fix the position of second column with square font+- Fix trailing spaces in dashboard+- Fix a trailing space in a message+- Fix disable extra empty shadow line at the bottom of menus+- Fix determining if item identified in permittedPrecious+- Fix an actor pulling himself+- Fix desynchronized copy-pasted actorVulnerable code+- Fix history message display header+- Fix Calm measurement code to match code documentation+- Fix sleeping stash guard not considered a guard+- Fix reaching escape from below when all levels explored+- Fix hero AI sometimes not exploring levels fully+- Fix weapon order of Smithhammer+- Fix messages about melee-only armor deflecting missiles+- Fix wrong condition, wrongly reducing fleeing behaviour+- Fix comments about slack doctrine targets+- Fix assertion failure when targetting a tile under oneself+- Fix code documentation about inventory stores+- Fix the unequipping failure message condition+- Fix wrong cave reversal when generating dungeon+- Fix non-pointman heroes meleeing healing geysers+- Fix poisons never activating and never running out+- Fix registering if altering failed due to bumping+- Fix a bushy patch that can block starting actors+- Fix diverging definitions of foes worth killing+- Fix barrels not destroyed by bumping+- Fix inability to open doors due to no embeds+- Fix projectiles not to bump off, but to transform terrain+- Fix the display of level in stash menu header+- Fix alliance placing to put heroes over stairs+- Fix a wrong message when displacing a waking foe+- Fix AI not eating and not removing other bad conditions+- Fix nested macros+- Fix wrong game mode started due to only the first word inspected+- Fix the result of AndEffect+- Fix the warning when flinging benign items+- Fix a loop when actor pushed to another level via stairs+- Fix melee disrupting pushed flight+- Fix unidentified weapons marked in HUD as without timeout+- Fix modelling wear and tear with DestroyItem+- Fix mixed up resistance conditions+- Fix item dropping crashes when OnSmash effects remove them while dropped+- Fix an AI loop when applying a recharging item+- Fix some no-fence places not appearing in statistics+- Fix display of empty lists of tools for terrain transformations+- Fix referring in the server code to definitions from the client internals+- Fix embedded items activated twice+- Fix an attempt to consume more items than there exist+- Fix broken running macro+- Fix activating embeds+- Fix repeating predefined macros+- Fix unsafe recording+- Fix in-game macro system+- Fix discharging an item that is not recharged+- Fix consumeItems missing in an export list+- Fix missing spaces in describeToolsAlternative+- Fix display of tool alternatives+- Fix random results of sortEmbeds+- Fix checks if actors in combat+- Fix the semantics of Discharge effect+- Fix a crash when updating invisible item timer+- Fix altering skill check in the client+- Fix omission of OpenWith when OpenTo is considered+- Fix unidentified embedded items impossible to trigger+- Fix usage of outdated state component when altering tiles+- Fix an attempt to apply a used up embedded item+- Fix the direction of < and > scrolling in ending screens+- Fix rubble tile definition wrt order of activated features+- Fix old actor body used after altering caused by collision with terrain+- Fix wrong condition for alien captured at victory message+- Fix moving only all or none items between containers+- Fix crash when actor not visible after triggering an item+- Fix crash when dopping previous may destroy next items+- Fix projectile altering a tile too many times at once+- Fix DropItem reporting no activation due to item vanishing earlier+- Fix off-by-one when picking projectiles with enough range+- Fix trying to destroy an empty item bag when modifying terrain with it+- Fix assumption that if last actor is alien, game is won+- Fix no identification message sometimes in the first turn+- Fix compilation without EXPOSE_INTERNAL+- Fix the trap of drain Calm item in equipment that can't be removed+- Fix tiles never altered via walking on them+- Fix articles incorrectly recognized in words that end similarly+- Fix wrong calculation of number of non-durable weapons+- Fix incorrect conjugation+- Fix a corruption of backstory text+- Fix first character of buttons sometimes overwritten by space+- Fix wrongly displaying a special ending for small scenarios+- Fix other frontends wrt engine and sdl2 frontend changes+- Fix proportional overlay overwriting first character of mono one+- Fix help setup for large screens+- Fix broken item menu with square font+- Fix wrong button initial position with square font+- Fix distant overlays wrongly getting a highlighted line+- Fix SDL frontend truncating proportional font lines+- Fix and tweak measuring texts in various fonts+- Fix empty menus in single font mode+- Fix spurious ending prompt in single-font setup+- Fix padding of line chunks overwriting subsequent chunks+- Fix display of history+- Fix buttons holding other locations of an item+- Fix not shown highlight of prop font lines+- Fix spurious empty line between header and menu+- Fix use of fromAscList where fromDistinctAscList would do+- Fix spacing in history display+- Fix off-by-one crash in history+- Fix mouse clicks on buttons in small font areas+- Fix updateLine for the case of multiple overlays+- Fix overrun in mouse help table+- Fix history highlight restricted to 80 columns+- Fix menu highlight splitting proportional text chunks+- Fix proportional texts never wiped out+- Fix horizontal starting points of message chunks+- Fix a syntax error stemming from wrong CPP+- Fix illegal containers creeping into item choice+- Fix cmdAtomicSemSer for UpdMoveItem+- Fix AI not sidestepping explosive tiles, even if it could+- Fix AI not sidestepping nearby actors+- Fix cmdAtomicSemSer in the presense of CStash that acts like CFloor+- Fix broken atomic commands assigned wrong LevelId+- Fix visible enemy stash position not updated, because foes not seen+- Fix countless typos+- Start using cabal-plan+- Fix and improve Makefile, cabal file and CI scripts+- Improve and update game manual and help texts wrt game changes+- Tweak travis scripts and building docs in README++## [v0.9.5.0](https://github.com/LambdaHack/LambdaHack/compare/v0.9.4.0...v0.9.5.0)++- Fix NumLock disabled in the browser+- In screen reader frontend, highlight active menu line with the cursor+- Clone the main main menu commands as map mode commands+- Add C-RMB and C-S-LMB as alternatives of MMB+- Announce prominently MMB binding for describing map positions+- Clean up the default config file, keeping compatibility+- Make scenario names longer and slighlty more informative+- Make Vi movement keys the default in addition to keypad and mouse+- Fix a bug where death prompt when autoplaying was capturing a keypress+- Let ESC from main menu return to insert coin mode, if applicable+- Make various small UI tweaks, especially to main menu and its submenu+- Let main menu lines have 35, not 30, characters+- Make the main menu ASCII art less intrusive (and easier for screen readers)+- Don't invalidate the score file due to game minor (only) version bump++## [v0.9.4.0](https://github.com/LambdaHack/LambdaHack/compare/v0.9.3.0...v0.9.4.0)++- In vty frontend highlight actors more+- Clean up actor highlighting+- Add yell/yawn to minimal command set, remove swerving the aiming line+- Invoke yell/yawn exclusively with '%', due tor Windows and terminal woes+- Move C-c command to C, not to mask C-c on console frontends+- Tweak and fix vty console frontends, for screen-readers+- React specially at gameover under certain special circumstances+- Simpliy assignSlot now that slots are auto-sorted+- Get rid of explicit item sorting; let lore and menu slots agree+- Make DetectExit non-modal+- Mark in a game end confirmation message that more treasure can be found+- Add a description to the escape embedded item+- Reword gameover text for raid scenario+- Be more verbose when confirming escape from the game+- Don't claim to summon, when not possible on this level+- Fix missing 'no longer poisoned' when applying antidote+- Don't ask confirmation for neutral (e.g., not IDed) items+- Fix 'you fall down; you stand on a sword'+- Prevent selecting regions via mouse down in web frontend+- Deselect item if player declines to apply or fling+- Hand-hold the player, warning if flung item is beneficial+- Hand-hold the player, warning if applied item is harmful+- Rewrite the condition in UI applyItem check+- Improve the lobable item skill failure message+- Let mouse buttons describe tiles, etc.+- Unblock S-MouseButton in SDL2 frontend+- Always describe things under mouse button+- Make the message when hitting dead foe more varied++## [v0.9.3.0, aka 'Velvet smoking jacket'](https://github.com/LambdaHack/LambdaHack/compare/v0.8.3.0...v0.9.3.0)++- Introduce message classes with configurable behaviour+- Create a new 16x16 font and use it everywhere; tweak smaller fonts+- Lock some levels or otherwise make ascending tricky+- Add cooldown to most melee weapons, display that in HUD, adjust AI+- Add per-scenario and per-outcome gameover messages in content+- Add duplicate and reroll item effects in preparation for crafting+- Add actor and item analytics as a preparation for XP gain quests+- Implement piercing projectiles that may share a tile with a big actor+- Increase the spawn speed now that monsters sleep a lot+- Introduce actors falling asleep and yelling+- Allow any level size and position+- Mention places when looking at tiles and add place lore menu+- Expand all kinds of content and rebalance+- Create and rework all item, cave and plot prose (Dan Keefe @Peritract)+- Make explosives in cramped spaces twice weaker+- Tweak player fling command+- Tweak equipping when equipment overfull+- Start cycling stores at equipment since that's the one mentioned in help+- Overhaul CI scripts+- Restructure and clean up codebase+- Extend balance debugging tools, using item and actor analytics, places, etc.+- Drop the gameplay option that first death means defeat+- Avoid idle-GC between slow keystrokes+- Put content data into a compact region to limit GC+- Remove the border around web frontend game screen; seems unneeded now+- Don't draw aiming line nor path in vty frontend+- Highlight xhair by cursor in vty frontend+- Highlight player by cursor in vty frontend+- Switch the default FPS to 24 for tradition's sake+- Highlight current high score+- Remove most stopPlayBack, now spurious, because message classes used+- Overhaul cabal file: define common options, split into internal libraries+- Fix confusion of nub and uniq+- Rename short wait to lurk and many lurks to heed+- Show a red message when HP or Calm dip too low or when foe appears+- Lose Calm and so alert AI even at weakest non-zero HP draining attacks+- Enable screenshots while in menus+- Rename config options related to fonts+- Recolour aiming line not to clash with the red crosshair+- Exchange the functions of yellow and red highlight+- Tweak all colours, in particular to differentiate blues/cyans+- Cap bright colours at 85 CIELAB Lightness at D65+- Normalize dark colours to be between 42 and 57 CIELAB Lightness at D65+- Get rid of colorIsBold option; KISS+- Tint white in alternating lines with different hue for long text readability+- Don't split lines at articles+- Set xhair to currently meleed foe to see his HP+- Display speed on HUD; tweak status lines in other ways+- Don't show description of leader target in HUD; TMI+- Help AI flee in a consistent direction over many turns+- Expose the save backup command, for browser games+- Don't display target info when item selected+- Let AI actors spawn even quite far from the player+- Auto-select all new team members, to help new players+- Replace O by zero on the map display; make zero distinct from O in all fonts+- Flesh out the initial ? prompt+- Add 'I' alias for pack-related commands, unless laptop key-scheme used+- Turn off movementLaptopKeys by default not to confuse new players+- Make sure AI attacks bosses even if distant and fleeing or non-moving+- Lower bonus HP at extreme difficulty+- Add a separate frame for each projectiles start+- Don't go modal at the frequent and weak hidden tile detection effect+- Make AI pick closest stairs more often+- Let apply-unskilled actors activate embedded items+- Don't boost damage by speed unless actor is projectile+- If everything else fails, let AI flee by opening doors+- Help AI actor prevent being dominated+- Make computing gameplay benefit to items more accurate+- Rename, clone and fine-tune effect Temporary+- Simplify code and content by getting rid of Recharging effect+- Let applying periodic items only produce the first effect+- Tweak item detection to help in skipping boring level portions and in stealth+- Invoke and display embedded items in the order specified in tile definitions+- Let lit trails illuminate colonnades+- Prevent an exploit for avoiding self-invoked firecrackers+- Don't let AI attempt summoning if not enough Calm+- Improve item label bracket codes in menus+- Pick randomly destination stairs if teleporting level+- Display the number of items in store+- Summarize value of player loot in shared stash menu's header+- Start history menu at the close-up of the last message+- Make fast-dying insects aggressive+- Overhaul game score DSL and particular scoring definitions in content+- Add and extend messages, e.g., tell if victim blocks and with what armor+- Extend and rework menu manipulation keys+- Remove specialized quaff, read and throw commands; KISS+- Split walls of text into more paragraphs and/or make them narrower+- Extend and update help and manual+- Don't let AI waste time looting distant lone projectiles+- Make Enum instances of Point and Vector contiguous, hackily+- Make dominated actor drop all his items, for ID and in case he defects ASAP+- Try to find a non-waiting action, if better AI leader can't be found+- Prevent summoning OoD actors+- Let animals eat food and add several foods+- Make Domination effect harder to activate+- Let only actors and items with SkOdor property leave smell and add perfumes+- Let spawning rate level out after a few dozen spawns+- Describe smell, if present in an inspected tile+- Let pushed actor fly after crashing a door open+- Show passing time and heard events even if no actors in the UI faction+- When movement impossible, describe the tile with SHIFT-direction+- Catch and steal projectiles when braced instead of when weaponless+- Let actors that are pushed perform any action in addition to movement+- Improve deduplication of messages+- When describing actor on map, tell if it has loot+- Represent being braced as having an organ; also add other pseudo-organs+- Overhaul hearing to facilitate triangulation based on sound cues+- Prefer to spawn aquatic actors on aquatic tiles+- Add swimming and flying skills and shallow water tile features+- Boost/drain skills via many new items+- Rework and extend skills and their effects as a preparation for XP rewards+- Enable specifying each side of outer cave fence separately+- Make definition of caves of a scenario more precise+- Specify more properties of levels in content+- Extend content validation+- Improve placement and fitting stairs and rooms on levels+- Don't hardwire level size+- Simplify game rules content+- Change the format of game client content+- Fix an arbitrary delay in killing dying actors+- Fix arbitrary branch of a corridor chosen when running+- Fix bush patches blocking off a level's corner+- Fix config file ignored at game reinit+- Fix running disturbed by flavours of walls+- Fix splitting lines one character too early+- Fix Calm drain from nearby foes occurring only every other turn+- Fix some AI looping movement, in particular when fleeing+- Fix running into own periodic explosions, e.g., from necklaces+- Fix 'she painfullies collide'+- Fix AI with vector targets unwilling to change them+- Fix crash when attempting to fling at a target on remote level+- Fix wrong timestamps in history+- Fix, again, various kinds of frames intruding between fadeout and fadein+- Fix wrong pluralization of some item names, compound and exceptions+- Fix disabled items benefit recalculation after item kind learned+- Fix in many ways too close initial faction and item positions+- Fix performance in many ways and places, particularly for JS translation+- Fix missing perception updates, causing missed AI actions concerning us+- Fix uninitialized sarenas, which was probably causing resume to change state+- Fix weak AI actors fleeing even if enemy can't melee+- Fix and optimize sifting free tiles for spawn/summon location+- Fix various cases of excessive summoning+- Fix recording of item first seen level+- Fix many problems with item descriptions and other messages+- Fix reporting of reduction and elimination of actor conditions+- Fix reading and interpreting old format config files+- Fix synced initial item timeouts and actor times, leading to artificial feel+- Fix actors erratically following their leader+- Fix lifts continuing as stars and the other way around+- Fix various 32bit overflows+- Fix other errors, probably not present or not visible in previous version++## [v0.8.3.0](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.2...v0.8.3.0)++- Add a hack to run SDL2 on the main thread, fixing the OS X crash+- Warn visually when impressed and Calm running low, risking domination+- Display actor as red when low Calm and impressed or when low HP+- Fix, complete and fine tune UI, AI and server skill and weapon checks+- Fix a bug where item aspects look different to clients than to the server+- Change the requirements for the main menu ASCII art++## [v0.8.1.2](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.1...v0.8.1.2)++- Fix typos detected by lintian+- Fix the code that runs in case of old async (bug introduced in v0.8.1.1)++## [v0.8.1.1](https://github.com/LambdaHack/LambdaHack/compare/v0.8.1.0...v0.8.1.1)++- no player-visible changes+- make it possible to compile with old async package+- rewrite copyright information according to Debian format+- make github display the correct main license++## [v0.8.1.0](https://github.com/LambdaHack/LambdaHack/compare/v0.8.0.0...v0.8.1.0)++- no player-visible changes+- significantly reduce RAM usage when compiling library+- update and extend CI++## [v0.8.0.0, aka 'Explosive dashboard'](https://github.com/LambdaHack/LambdaHack/compare/v0.7.1.0...v0.8.0.0)++- rework greying out menu items and permitting item application and projection+- rework history collection; merge message repetitions more aggressively+- display HP in red when below (configurable) warning threshold+- tweak AI: actors remember they are fleeing; better leader choice, etc.+- add to content specialized explosive projectiles; tune the effects+- calculate loot score component based on fraction of dungeon loot collected+- don't hardwire item price, but let it be specified in content+- let all valuables glitter in the dark to avoid complete level exploration+- teach AI to cure ailments and shake off impressions+- rework detection effects; add detection of items embedded in tiles+- automatically identify stolen items that only have minor effects+- let projectiles hit each other if fragile and substantial enough+- rework item kind identification code; change the way it's defined in content+- make more item kinds (including some traps) secret+- protect paralyzed actors with a stasis condition to avoid infinite paralysis+- implement dumping screenshots in SDL2 and create animated GIFs in Makefile+- generate most common consumables less often, but in depth-scaled bunches+- make pushed actors alter tiles and trigger effects of embedded items+- validate and cross-validate more content; reduce content creation boilerplate+- make summoning more varied and prevent chain-summoning+- add many ways to conditionally sequence effects+- create large, merged rooms more often+- generalize the terrain altering player command (C-c, mouse)+- let RET, SPACE and ESC clear pending messages, if any+- add dashboard with links to all menus and info screens+- scale some organ and trap power with level depth+- simplify level-scaled dice roll semantics+- change scaled dice notation 'dl' to 'dL' for readability in-game+- rebalance items and decrease dice variety to unclutter backpack+- colour-code beneficial and harmful conditions in menu and in HUD+- display item lore (also for organs, embedded items, explosions, etc.)+- display embedded item descriptions as if they were tile descriptions+- tweak blast visuals, lower particle counts, beautify their spread+- tweak projectile visuals, e.g., display an extra frame when projectile dies+- add intro screen and work on other ways to convey story+- simplify a lot of code, including a bit of game rules+- fix some bugs, tweak content, speed up some AI bottlenecks++## [v0.7.1.0, aka 'Ancient troubles'](https://github.com/LambdaHack/LambdaHack/compare/v0.7.0.0...v0.7.1.0)++- add amazing cave and item (actor, blast, organ) descriptions+- package for Windows as an installer and also as zip archives+- fix a crash from SDL frontend under some OpenGL drivers (no thread-safety)+- add WWW address to the Main Menu, for other sites that may run our JS blob++## [v0.7.0.0, aka 'The dice are cast'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.2.0...v0.7.0.0)++- decouple tile searching from tile alteration+- refrain from identifying items that are not randomized+- switch away from incapacitated leader to let others revive him+- make rescue easier by not going into negative HP the first time+- fix crowd of friends on another level slowing even actors that melee+- fix missing report about items underneath an actor when changing levels+- API breakage: change the syntax of dice in content+- API addition: introduce cave descriptions+- keep all client states in the server and optimize communication with clients+- improve item choice for identification and item polymorphing+- reset embedded items when altering tile+- replace atomic command filtering with exception catching+- reimplement dice as symbolic expressions inducing multiple RNG calls+- switch to optparse-applicative and rewrite cli handling+- add stack and cabal new-build project files+- improve haddocks across the codebase++## [v0.6.2.0, aka 'Zoom out'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.1.0...v0.6.2.0)++- make fireworks slower and so easier to spot+- make rattlesnake deeper but more common+- announce no effect of activation+- describe original and current faction of an actor+- highlight dominated actors+- mark organs with comma instead of percent and gems with dollar+- make the healing cave dangerous to prevent camping+- slightly balance various content+- by default move item the same as last time+- often spawn between heroes and stairs going deeper+- fix totalUsefulness computation for negative effects+- fix abandoning distant enemy target despite no alternatives+- fix slow pushing of actors+- fix a crash when many actors run towards stairs+- hotfix: Pass zoom keys through to the browser+- help players find the info about changing the font size+- depend on GHC >= 8.0 and new vector+- specialize client code already in SampleMonadClient.hs+- enable StrictData in all modules+- replace 'failure' with 'error' that now shows call stack++## [v0.6.1.0, aka 'Breaking one rule at a time'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.0.0...v0.6.1.0)++- fix redrawing after window minimized and restored+- hack around vanishing texture on Windows+- hack around SDL backends not thread-safe on Windows+- the only breaking API change: specify font directory in game rules content+- let the game use its own fonts, not fonts from the sample game in library+- tweak some item creation to occur in character's pack, not on the ground+- slightly balance various content+- make sure the 'resolution' effect is not a drawback+- make artifact weapon rarities more regular+- avoid creating lit, open dungeon at the bottom, where foes have ranged weapons+- number scenarios in user descriptions+- correct, add and modify some in-game messages+- let player hear unseen summonings performed by other actors+- don't let actors hear blasts hitting walls, as opposed to hitting actors+- when moving item out of shared stash, reset its timeouts+- when ascending, shift timeouts of inventory as well+- when creating item not on the ground, discover it+- when dominating, auto-discover only if the item can't be discovered by use+- let henchmen take into account their targets, as described in PLAYING.md+- let only walkable tiles be explorable, for clear walls inside solid blocks+- move to API 2.0.0 of sdl2-ttf and depend on corrected sdl2 (builds on Windows)+- simplify code thanks to the new sdl2-ttf API+- tweak travis scripts and building docs in README++## [v0.6.0.0, aka 'Too much to tell'](https://github.com/LambdaHack/LambdaHack/compare/v0.5.0.0...v0.6.0.0)++- add and modify a lot of content: items, tiles, embedded items, scenarios+- improve AI: targeting, stealth, moving in groups, item use, fleeing, etc.+- make monsters more aggressive than animals+- tie scenarios into a loose, optional storyline+- add more level generators and more variety to room placement+- make stairs not walkable and use them by bumping+- align stair position on the levels they pass through+- introduce noctovision+- increase human vision to 12 so that normal speed missiles can be sidestepped+- tweak and document weapon damage calculation+- derive projectile damage mostly from their speed+- make heavy projectiles better vs armor but easier to sidestep+- improve hearing of unseen actions, actors and missiles impacts+- let some missiles lit up on impact+- make torches reusable flares and add blankets for dousing dynamic light+- add detection effects and use them in items and tiles+- make it possible to catch missiles, if not using weapons+- make it possible to wait 0.1 of a turn, at the cost of no bracing+- improve pathfinding, prefer less unknown, alterable and dark tiles on paths+- slow down actors when acting at the same time, for speed with large factions+- don't halve Calm at serious damage any more+- eliminate alternative FOV modes, for speed+- stop actors blocking FOV, for speed+- let actor move diagonally to and from doors, for speed+- improve blast (explosion) shapes visually and gameplay-wise+- add SDL2 frontend and deprecate GTK frontend+- add specialized square bitmap fonts and hack a scalable font+- use middle dot instead of period on the map (except in teletype frontend)+- add a browser frontend based on DOM, using ghcjs+- improve targeting UI, e.g., cycle among items on the map+- show an animation when actor teleports+- add character stats menu and stat description texts+- add item lore and organ lore menus+- add a command to sort item slots and perform the sort at startup+- add a single item manipulation menu and let it mark an item for later+- make history display a menu and improve display of individual messages+- display highscore dates according to the local timezone+- make the help screen a menu, execute actions directly from it+- rework the Main Menu+- rework special positions highlight in all frontends+- mark leader's target on the map (grey highlight)+- visually mark currently chosen menu item and grey out impossible items+- define mouse commands based on UI mode and screen area+- let the game be fully playable only with mouse, use mouse wheel+- pick menu items with mouse and with arrow keys+- add more sanity checks for content+- reorganize content in files to make rebasing on changed content easier+- rework keybinding definition machinery+- let clients, not the server, start frontends+- version savefiles and move them aside if versions don't match+- lots of bug fixes internal improvements and minor visual and text tweaks++## [v0.5.0.0, aka 'Halfway through space'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.101.0...v0.5.0.0)++- let AI put excess items in shared stash and use them out of shared stash+- let UI multiple items pickup routine put items that don't fit into equipment into shared stash, if possible, not into inventory pack+- re-enable the ability to hear close, invisible foes+- add a few more AI and autonomous henchmen tactics (CTRL-T)+- keep difficulty setting over session restart+- change some game start keybindings+- replace the Duel game mode with the Raid game mode+- various bugfixes, minor improvements and balancing++## [v0.4.101.0, aka 'Officially fun'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.100.0...v0.4.101.0)++- the game is now officially fun to play+- introduce unique boss monsters and unique artifact items+- add animals that heal the player+- let AI gang up, attempt stealth and react to player aggressiveness+- spawn actors fast and close to the enemy+- spawn actors less and less often on a given level, but with growing depth+- prefer weapons with effects, if recharged+- make the bracing melee bonus additive, not multiplicative+- let explosions buffet actors around+- make braced actors immune to translocation effects+- use mouse for movement, actor selection, aiming+- don't run straight with selected actors, but go-to cross-hair with them+- speed up default frame rate, slow down projectiles visually+- rework item manipulation UI+- you can pick up many items at once and it costs only one turn+- allow actors to apply and project from the shared stash+- reverse messages shown in player diary+- display actor organs and stats+- split highscore tables wrt game modes+- move score calculation formula to content+- don't keep the default/example config file commented out; was misleading+- I was naughty again and changed v0.5.0.0 of LambdaHack content API slightly+  one last time++## [v0.4.100.0, aka 'The last thaw'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.99.0...v0.4.100.0)++- unexpectedly thaw and freeze again v0.5.0.0 of LambdaHack content API+- unexpectedly implement timeouts and temporary effects easily without FRP+- make a couple of skill levels meaningful and tweak skills of some actors+- make AI prefer exploration of easier levels+- permit overfull HP and Calm+- let non-projectile actors block view+- make colorful characters bold (if it resizes your fonts, turn off via colorIsBold = False in config file or --noColorIsBold on commandline)+- start the game with a screensaver safari mode+- add i386 Linux and Windows compilation targets to Makefile++## [v0.4.99.0, aka 'Player escapes'](https://github.com/LambdaHack/LambdaHack/compare/v0.2.14...v0.4.99.0)++- balance the example game content a bit (campaign still unbalanced)+- various code and documentation tweaks and fixes+- add cabal flag expose_internal that reveals internal library operations+- merge FactionKind into ModeKind and rework completely the semantics+- compatibility tweaks for Nixpkgs+- define AI tactics, expose them to UI and add one more: follow-the-leader+- share leader target between the UI and AI client of each faction+- specify monster spawn rate per-cave+- extend content validation and make it more user friendly+- freeze v0.5.0.0 of LambdaHack content API+ ## [v0.2.14, aka 'Out of balance'](https://github.com/LambdaHack/LambdaHack/compare/v0.2.12...v0.2.14)  - tons of new (unbalanced) content, content fields, effects and descriptions
+ COPYLEFT view
@@ -0,0 +1,247 @@+Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/+Upstream-Name: LambdaHack+Upstream-Contact: Mikolaj Konarski <mikolaj.konarski@funktory.com>+Source: https://hackage.haskell.org/package/LambdaHack++Files: *+Copyright: 2008-2011 Andres Loeh+           2010-2023 Mikolaj Konarski and others (see git history)+License: BSD-3-Clause++Files: GameDefinition/fonts/*.fnt GameDefinition/fonts/*.bdf GameDefinition/fonts/16x16xw.woff+Copyright: 1997-2016 Leon Marrick+           1997-2016 Sheldon Simms III+           1997-2016 Nick McConnell+           2016-2023 Mikolaj Konarski+License: GPL-2.0-or-later++Files: GameDefinition/fonts/Binary*.woff+Copyright 2010-2019 Adobe (http://www.adobe.com/), with Reserved Font Name 'Source'+Copyright 2023 Mikolaj Konarski+License: OFL-1.1++Files: GameDefinition/fonts/DejaVu*.woff+Copyright: Copyright (c) 2003 by Bitstream, Inc. All Rights Reserved.+ Bitstream Vera is a trademark of Bitstream, Inc.+ DejaVu changes are in public domain.+License: bitstream-vera+Comment:+ Bitstream Vera Sans Mono is Copyright Bitstream Inc. and licensed under the+ Bitstream Vera License with Reserved Font Names "Bitstream" and "Vera".+ .+ DejaVu modifications of the original Bitstream Vera Sans Mono typeface have+ been committed to the public domain.+ .+ The work in the Hack project is licensed under the MIT (Expat) License.+ .+ Copied from https://metadata.ftp-master.debian.org/changelogs//main/f/fonts-dejavu/fonts-dejavu_2.37-2_copyright++Files: GameDefinition/fonts/Hack*.woff+Copyright:+ 2003 Bitstream Inc.+ 2018 Christopher Simpkins <chris@sourcefoundry.org>+License: Expat and bitstream-vera+Comment:+ Bitstream Vera Sans Mono is Copyright Bitstream Inc. and licensed under the+ Bitstream Vera License with Reserved Font Names "Bitstream" and "Vera".+ .+ DejaVu modifications of the original Bitstream Vera Sans Mono typeface have+ been committed to the public domain.+ .+ The work in the Hack project is licensed under the MIT (Expat) License.+ .+ Copied from https://metadata.ftp-master.debian.org/changelogs//main/f/fonts-hack/fonts-hack_3.003-3_copyright++Files: debian/*+Copyright: held by the contributors mentioned in debian/changelog+License: BSD-3-Clause++License: BSD-3-Clause+ Redistribution and use in source and binary forms, with or without+ modification, are permitted provided that the following conditions+ are met:+ 1. Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.+ 2. Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.+ 3. Neither the name of the copyright holder nor the names of its+    contributors may be used to endorse or promote products derived from+    this software without specific prior written permission.+ .+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+ AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+ DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++License: GPL-2.0-or-later+ This program is free software; you can redistribute it+ and/or modify it under the terms of the GNU General Public+ License, version 2, as published by the Free Software Foundation+ .+ This program is distributed in the hope that it will be+ useful, but WITHOUT ANY WARRANTY; without even the implied+ warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR+ PURPOSE.  See the GNU General Public License for more+ details.+ .+ You should have received a copy of the GNU General Public+ License along with this package; if not, write to the Free+ Software Foundation, Inc., 51 Franklin St, Fifth Floor,+ Boston, MA  02110-1301 USA+ .+ On Debian systems, the full text of the GNU General Public+ License version 2 can be found in the file+ `/usr/share/common-licenses/GPL-2'.++License: OFL-1.1+ SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007+ .+ PREAMBLE+ The goals of the Open Font License (OFL) are to stimulate worldwide+ development of collaborative font projects, to support the font+ creation efforts of academic and linguistic communities, and to+ provide a free and open framework in which fonts may be shared and+ improved in partnership with others.+ .+ The OFL allows the licensed fonts to be used, studied, modified and+ redistributed freely as long as they are not sold by themselves. The+ fonts, including any derivative works, can be bundled, embedded,+ redistributed and/or sold with any software provided that any+ reserved names are not used by derivative works. The fonts and+ derivatives, however, cannot be released under any other type of+ license. The requirement for fonts to remain under this license+ does not apply to any document created using the fonts or their+ derivatives.+ .+ DEFINITIONS+ Font Software refers to the set of files released by the+ Copyright Holder(s) under this license and clearly marked as such.+ This may include source files, build scripts and documentation.+ .+ Reserved Font Name refers to any names specified as such after+ the copyright statement(s).+ .+ Original Version refers to the collection of Font Software+ components as distributed by the Copyright Holder(s).+ .+ Modified Version refers to any derivative made by adding to,+ deleting, or substituting in part or in whole any of the components+ of the Original Version, by changing formats or by porting the Font+ Software to a new environment.+ .+ Author refers to any designer, engineer, programmer, technical+ writer or other person who contributed to the Font Software.+ .+ PERMISSION & CONDITIONS+ Permission is hereby granted, free of charge, to any person+ obtaining a copy of the Font Software, to use, study, copy, merge,+ embed, modify, redistribute, and sell modified and unmodified copies+ of the Font Software, subject to the following conditions:+ .+ 1) Neither the Font Software nor any of its individual components,+    in Original or Modified Versions, may be sold by itself.+ .+ 2) Original or Modified Versions of the Font Software may be bundled,+    redistributed and/or sold with any software, provided that each+    copy contains the above copyright notice and this license. These+    can be included either as stand-alone text files, human-readable+    headers or in the appropriate machine-readable metadata fields+    within text or binary files as long as those fields can be easily+    viewed by the user.+ .+ 3) No Modified Version of the Font Software may use the Reserved Font+    Name(s) unless explicit written permission is granted by the+    corresponding Copyright Holder. This restriction only applies to+    the primary font name as presented to the users.+ .+ 4) The name(s) of the Copyright Holder(s) or the Author(s) of the+    Font Software shall not be used to promote, endorse or advertise+    any Modified Version, except to acknowledge the contribution(s)+    of the Copyright Holder(s) and the Author(s) or with their+    explicit written permission.+ .+ 5) The Font Software, modified or unmodified, in part or in whole,+    must be distributed entirely under this license, and must not be+    distributed under any other license. The requirement for fonts to+    remain under this license does not apply to any document created+    using the Font Software.+ .+ TERMINATION+ This license becomes null and void if any of the above conditions+ are not met.+ .+ DISCLAIMER+ THE FONT SOFTWARE IS PROVIDED AS IS, WITHOUT WARRANTY OF ANY KIND,+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT+ OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL+ THE COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+ LIABILITY, INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR+ CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR+ OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO USE THE FONT+ SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE.++License: bitstream-vera+ Permission is hereby granted, free of charge, to any person obtaining a copy+ of the fonts accompanying this license ("Fonts") and associated documentation+ files (the "Font Software"), to reproduce and distribute the Font Software,+ including without limitation the rights to use, copy, merge, publish,+ distribute, and/or sell copies of the Font Software, and to permit persons to+ whom the Font Software is furnished to do so, subject to the following+ conditions:+ .+ The above copyright and trademark notices and this permission notice shall be+ included in all copies of one or more of the Font Software typefaces.+ .+ The Font Software may be modified, altered, or added to, and in particular the+ designs of glyphs or characters in the Fonts may be modified and additional+ glyphs or characters may be added to the Fonts, only if the fonts are renamed+ to names not containing either the words "Bitstream" or the word "Vera".+ .+ This License becomes null and void to the extent applicable to Fonts or Font+ Software that has been modified and is distributed under the "Bitstream Vera"+ names.+ .+ The Font Software may be sold as part of a larger software package but no copy+ of one or more of the Font Software typefaces may be sold by itself.+ .+ THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS+ OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF MERCHANTABILITY,+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT OF COPYRIGHT, PATENT,+ TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL BITSTREAM OR THE GNOME FOUNDATION+ BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, INCLUDING ANY GENERAL,+ SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, WHETHER IN AN ACTION+ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF THE USE OR INABILITY TO+ USE THE FONT SOFTWARE OR FROM OTHER DEALINGS IN THE FONT SOFTWARE.+ .+ Except as contained in this notice, the names of Gnome, the Gnome Foundation,+ and Bitstream Inc., shall not be used in advertising or otherwise to promote+ the sale, use or other dealings in this Font Software without prior written+ authorization from the Gnome Foundation or Bitstream Inc., respectively. For+ further information, contact: fonts at gnome dot org.++License: Expat+ Permission is hereby granted, free of charge, to any person obtaining a+ copy of this software and associated documentation files (the "Software"),+ to deal in the Software without restriction, including without limitation+ the rights to use, copy, modify, merge, publish, distribute, sublicense,+ and/or sell copies of the Software, and to permit persons to whom the+ Software is furnished to do so, subject to the following conditions:+ .+ The above copyright notice and this permission notice shall be included+ in all copies or substantial portions of the Software.+ .+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+ THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR+ OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,+ ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+ OTHER DEALINGS IN THE SOFTWARE.
CREDITS view
@@ -3,3 +3,110 @@  Andres Loeh Mikolaj Konarski+Tuukka Turto+Veronika Romashkina+Daniel Keefe+Pablo Reszczynski+Rafał Szczerski+Oleg Grenrus+Simon Michael+bulbousBullfrog+Alex Byaly+Jamie Fristrom+Kayvan Kazeminejad++++Binary distributions of this package may be linked or bundled with libraries+such as SDL2, SDL_ttf, FreeType and many others. These libraries+are copyright of their respective owners, with all rights reserved.+In particular, portions of this software are copyright © 2023 The FreeType+Project (www.freetype.org). All rights reserved.++++Fonts 16x16xw.woff, 16x16xw.bdf, 16x16x.fnt, 8x8x.fnt and 8x8xb.fnt+are are derived from fonts taken from+https://github.com/angband/angband, copyrighted by Leon Marrick,+Sheldon Simms III and Nick McConnell and released by them under+GNU GPL, version 2 or any later version (confirmed at+http://www.thangorodrim.net/development/opensource.html).+Any further modifications by authors of LambdaHack+are also released under GNU GPL version 2.++Font 16x16xw.bdf is derived from 16x16x.fon by changing all but+a few glyphs, converting to BDF format, extending character set+and hacking the font file with bdftopcf and pcf2bdf to include+full bitmaps, not only non-zero portions, for otherwise SDL2-ttf+was not able to display the glyphs.+Font 16x16xw.woff was derived from 16x16xw.bdf by changing format+to TTF with bitsnpicas, faking descendent offsets to be 1 point lower+to prevent freetype from adding an extra pixel to the descendent,+tweaking with fontforge glyphs 3 5 6 8 A a S s b d h to prevent antialiasing+of their vital parts when zoomed out, auto-hinting, manually simplifying+hints in some glyphs and converting to WOFF format.++++Fonts BinarySansProLH-Regular.ttf.woff, BinarySansProLH-Semibold.ttf.woff+and BinaryCodeProLH-Bold.ttf.woff are compiled from sources+at https://github.com/adobe-fonts/source-sans-pro+and https://github.com/adobe-fonts/source-code-pro+published with the following copyright notice:++Copyright 2010-2019 Adobe (http://www.adobe.com/), with Reserved Font+Name 'Source'. All Rights Reserved. Source is a trademark of Adobe+in the United States and/or other countries.+This Font Software is licensed under the SIL Open Font License, Version 1.1.++The sources are modified and processed as follows (see+https://github.com/adobe-fonts/source-sans-pro/issues/193 for background):++in Roman/Instances/Semibold/font.ufo/glyphs/s.glif+put advance width="452"+rm Roman/Instances/Semibold/font.ufo/data/com.adobe.type.processedHashMap+bash build.sh+pyftfeatfreeze -f 'cv03' -S -U LH -R 'Source/Binary' target/TTF/SourceSansPro-Semibold.ttf BinarySansProLH-Semibold.ttf+pyftsubset BinarySansProLH-Semibold.ttf --unicodes="*" --flavor=woff --with-zopfli --output-file=BinarySansProLH-Semibold.ttf.woff++and similarly for BinarySansProLH-Regular.ttf.woff, while+for BinaryCodeProLH-Bold.ttf.woff the last steps are:++pyftfeatfreeze -f 'cv02' -S -U LH -R 'Source/Binary' target/TTF/SourceCodePro-Bold.ttf BinaryCodeProLH-Bold.ttf+pyftsubset BinaryCodeProLH-Bold.ttf --unicodes="*" --flavor=woff --with-zopfli --output-file=BinaryCodeProLH-Bold.ttf.woff++++Fonts DejaVuLGCSans.ttf.woff and DejaVuLGCSans-Bold.ttf.woff+are downloaded from https://github.com/dejavu-fonts/dejavu-fonts+and compresses with pyftsubset. Their copyright notice is+DejaVu fonts 2.37 (c)2004-2016 DejaVu fonts team.+Fonts are (c) Bitstream (see below). DejaVu changes are in public domain.++Font Hack-Bold.ttf.woff is downloaded from+https://github.com/source-foundry/Hack+and compresses with pyftsubset. Its copyright notice is+Hack work is (c) 2018 Source Foundry Authors. MIT License.+Bitstream Vera Sans Mono (c) 2003 Bitstream, Inc. (with Reserved Font+Names _Bitstream_ and _Vera_). Bitstream Vera License.++++The Ubuntu Font Family fonts are currently removed, because they are+a little too tall (some glyphs on consecutive lines are touching)+and also considered non-free by Debian and so we can't include them+in Debian and some other GNU/Linux distributions anyway.+If there is sufficient interest, they may be brought back.++They were fonts ubuntu-v14-latin-ext_latin-regular.ttf.woff,+ubuntu-v14-latin-ext_latin-500.ttf.woff+and ubuntu-mono-v9-latin-ext_latin-700.ttf.woff+that were generated via google-webfonts-helper.herokuapp.com+from 'Ubuntu Font Family' fonts with the following copyright notice:+Copyright 2011 Canonical Ltd. Licensed under the Ubuntu Font Licence 1.0++The files were compressed with pyftsubset to save some space and make+sure they are created from TTF, not coverted OTF fonts. Unfortunately,+being TTF fonts and having broken hinting in the mono variant, they+require forcing TTF.Light hinting in the SDL frontend. If ever OTF fonts+emerge, they should be used instead (similarly compressed).
− Game/LambdaHack/Atomic.hs 
@@ -1,17 +0,0 @@--- | Atomic game state transformations. TODO: haddocks.------ See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Atomic-  ( -- * Re-exported from MonadAtomic-    MonadAtomic(..)-  , broadcastUpdAtomic, broadcastSfxAtomic-    -- * Re-exported from CmdAtomic-  , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..)-    -- * Re-exported from PosAtomicRead-  , PosAtomic(..), posUpdAtomic, posSfxAtomic, seenAtomicCli, generalMoveItem-  ) where--import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Atomic.MonadAtomic-import Game.LambdaHack.Atomic.PosAtomicRead
− Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs 
@@ -1,183 +0,0 @@--- | Sending atomic commands to clients and executing them on the server.--- See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Atomic.BroadcastAtomicWrite-  ( handleAndBroadcast-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Key (mapWithKeyM_)-import Data.Maybe--import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Atomic.HandleAtomicWrite-import Game.LambdaHack.Atomic.MonadStateWrite-import Game.LambdaHack.Atomic.PosAtomicRead-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind---- TODO: split into simpler pieces----storeUndo :: MonadServer m => CmdAtomic -> m ()---storeUndo _atomic =---  maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser})---    $ Nothing   -- TODO: undoCmdAtomic atomic--handleCmdAtomicServer :: forall m. MonadStateWrite m-                      => PosAtomic -> CmdAtomic -> m ()-handleCmdAtomicServer posAtomic atomic =-  when (seenAtomicSer posAtomic) $ do---    storeUndo atomic-    handleCmdAtomic atomic---- | Send an atomic action to all clients that can see it.-handleAndBroadcast :: forall m a. MonadStateWrite m-                   => Bool -> Pers-                   -> (a -> FactionId -> LevelId -> m Perception)-                   -> m a-                   -> (FactionId -> ResponseAI -> m ())-                   -> (FactionId -> ResponseUI -> m ())-                   -> CmdAtomic-                   -> m ()-handleAndBroadcast knowEvents persOld doResetFidPerception doResetLitInDungeon-                   doSendUpdateAI doSendUpdateUI atomic = do-  -- Gather data from the old state.-  sOld <- getState-  factionD <- getsState sfactionD-  (ps, resets, atomicBroken, psBroken) <--    case atomic of-      UpdAtomic cmd -> do-        ps <- posUpdAtomic cmd-        let resets = resetsFovCmdAtomic cmd-        atomicBroken <- breakUpdAtomic cmd-        psBroken <- mapM posUpdAtomic atomicBroken-        return (ps, resets, map UpdAtomic atomicBroken, psBroken)-      SfxAtomic sfx -> do-        ps <- posSfxAtomic sfx-        atomicBroken <- breakSfxAtomic sfx-        psBroken <- mapM posSfxAtomic atomicBroken-        return (ps, False, map SfxAtomic atomicBroken, psBroken)-  let atomicPsBroken = zip atomicBroken psBroken-  -- TODO: assert also that the sum of psBroken is equal to ps-  -- TODO: with deep equality these assertions can be expensive. Optimize.-  assert (case ps of-            PosSight{} -> True-            PosFidAndSight{} -> True-            PosFidAndSer (Just _) _ -> True-            _ -> not resets-                 && (null atomicBroken-                     || atomicBroken == [atomic])) skip-  -- Perform the action on the server.-  handleCmdAtomicServer ps atomic-  -- Update lights in the dungeon. This is lazy, may not be needed or partially.-  persLit <- doResetLitInDungeon-  -- Send some actions to the clients, one faction at a time.-  let sendUI fid cmdUI =-        when (playerUI $ gplayer $ factionD EM.! fid) $ doSendUpdateUI fid cmdUI-      sendAI fid cmdAI = doSendUpdateAI fid cmdAI-      sendA fid cmd = do-        sendUI fid $ RespUpdAtomicUI cmd-        sendAI fid $ RespUpdAtomicAI cmd-      sendUpdate fid (UpdAtomic cmd) = sendA fid cmd-      sendUpdate fid (SfxAtomic sfx) = sendUI fid $ RespSfxAtomicUI sfx-      breakSend lid fid perNew = do-        let send2 (atomic2, ps2) =-              if seenAtomicCli knowEvents fid perNew ps2-                then sendUpdate fid atomic2-                else do-                  mleader <- getsState $ gleader . (EM.! fid) . sfactionD-                  case (atomic2, mleader) of-                    (UpdAtomic cmd, Just leader) -> do-                      body <- getsState $ getActorBody leader-                      loud <- loudUpdAtomic (blid body == lid) fid cmd-                      case loud of-                        Nothing -> return ()-                        Just msg -> sendUpdate fid $ SfxAtomic $ SfxMsgAll msg-                    _ -> return ()-        mapM_ send2 atomicPsBroken-      anySend lid fid perOld perNew = do-        let startSeen = seenAtomicCli knowEvents fid perOld ps-            endSeen = seenAtomicCli knowEvents fid perNew ps-        if startSeen && endSeen-          then sendUpdate fid atomic-          else breakSend lid fid perNew-      posLevel fid lid = do-        let perOld = persOld EM.! fid EM.! lid-        if resets then do-          perNew <- doResetFidPerception persLit fid lid-          let inPer = diffPer perNew perOld-              outPer = diffPer perOld perNew-          if nullPer outPer && nullPer inPer-            then anySend lid fid perOld perOld-            else do-              unless knowEvents $ do  -- inconsistencies would quickly manifest-                sendA fid $ UpdPerception lid outPer inPer-                let remember = atomicRemember lid inPer sOld-                    seenNew = seenAtomicCli False fid perNew-                    seenOld = seenAtomicCli False fid perOld-                -- TODO: these assertions are probably expensive-                psRem <- mapM posUpdAtomic remember-                -- Verify that we remember only currently seen things.-                assert (allB seenNew psRem) skip-                -- Verify that we remember only new things.-                assert (allB (not . seenOld) psRem) skip-                mapM_ (sendA fid) remember-              anySend lid fid perOld perNew-        else anySend lid fid perOld perOld-      send fid = case ps of-        PosSight lid _ -> posLevel fid lid-        PosFidAndSight _ lid _ -> posLevel fid lid-        -- In the following cases, from the assertion above,-        -- @resets@ is false here and broken atomic has the same ps.-        PosSmell lid _ -> do-          let perOld = persOld EM.! fid EM.! lid-          anySend lid fid perOld perOld-        PosFid fid2 -> when (fid == fid2) $ sendUpdate fid atomic-        PosFidAndSer Nothing fid2 -> when (fid == fid2) $ sendUpdate fid atomic-        PosFidAndSer (Just lid) _ -> posLevel fid lid-        PosSer -> return ()-        PosAll -> sendUpdate fid atomic-        PosNone -> return ()-  mapWithKeyM_ (\fid _ -> send fid) factionD--atomicRemember :: LevelId -> Perception -> State -> [UpdAtomic]-atomicRemember lid inPer s =-  -- No @UpdLoseItem@ is sent for items that became out of sight.-  -- The client will create these atomic actions based on @outPer@,-  -- if required. Any client that remembers out of sight items, OTOH,-  -- will create atomic actions that forget remembered items-  -- that are revealed not to be there any more (no @UpdSpotItem@ for them).-  -- Similarly no @UpdLoseActor@, @UpdLoseTile@ nor @UpdLoseSmell@.-  let inFov = ES.elems $ totalVisible inPer-      lvl = sdungeon s EM.! lid-      -- Actors.-      inPrio = concatMap (\p -> posToActors p lid s) inFov-      fActor ((aid, b), ais) = UpdSpotActor aid b ais-      inActor = map fActor inPrio-      -- Items.-      pMaybe p = maybe Nothing (\x -> Just (p, x))-      inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p (lfloor lvl)) inFov-      fItem p (iid, k) = UpdSpotItem iid (getItemBody iid s) k (CFloor lid p)-      fBag (p, bag) = map (fItem p) $ EM.assocs bag-      inItem = concatMap fBag inFloor-      -- Tiles.-      cotile = Kind.cotile (scops s)-      inTileMap = map (\p -> (p, hideTile cotile lvl p)) inFov-      atomicTile = if null inTileMap then [] else [UpdSpotTile lid inTileMap]-      -- Smells.-      inSmellFov = ES.elems $ smellVisible inPer-      inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov-      atomicSmell = if null inSm then [] else [UpdSpotSmell lid inSm]-  in inItem ++ inActor ++ atomicTile ++ atomicSmell
− Game/LambdaHack/Atomic/CmdAtomic.hs 
@@ -1,207 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | A set of atomic commands shared by client and server.--- These are the largest building blocks that have no components--- that can be observed in isolation.------ We try to make atomic commands respect the laws of energy and mass--- conservation, unless they really can't, e.g., monster spawning.--- For example item removal from inventory is not an atomic command,--- but item dropped from the inventory to the ground is. This makes--- it easier to undo the commands. In principle, the commands are the only--- way to affect the basic game state (@State@).------ See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Atomic.CmdAtomic-  ( CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..)-  , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic-  ) where--import Data.Binary-import Data.Int (Int64)-import Data.Text (Text)-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind as ItemKind-import Game.LambdaHack.Content.TileKind as TileKind--data CmdAtomic =-    UpdAtomic !UpdAtomic-  | SfxAtomic !SfxAtomic-  deriving (Show, Eq, Generic)--instance Binary CmdAtomic---- | Abstract syntax of atomic commands.-data UpdAtomic =-  -- Create/destroy actors and items.-    UpdCreateActor !ActorId !Actor ![(ItemId, Item)]-  | UpdDestroyActor !ActorId !Actor ![(ItemId, Item)]-  | UpdCreateItem !ItemId !Item !Int !Container-  | UpdDestroyItem !ItemId !Item !Int !Container-  | UpdSpotActor !ActorId !Actor ![(ItemId, Item)]-  | UpdLoseActor !ActorId !Actor ![(ItemId, Item)]-  | UpdSpotItem !ItemId !Item !Int !Container-  | UpdLoseItem !ItemId !Item !Int !Container-  -- Move actors and items.-  | UpdMoveActor !ActorId !Point !Point-  | UpdWaitActor !ActorId !Bool-  | UpdDisplaceActor !ActorId !ActorId-  | UpdMoveItem !ItemId !Int !ActorId !CStore !CStore-  -- Change actor attributes.-  | UpdAgeActor !ActorId !(Delta Time)-  | UpdRefillHP !ActorId !Int64-  | UpdRefillCalm !ActorId !Int64-  | UpdOldFidActor !ActorId !FactionId !FactionId-  | UpdTrajectory !ActorId-                       !(Maybe ([Vector], Speed))-                       !(Maybe ([Vector], Speed))-  | UpdColorActor !ActorId !Color.Color !Color.Color-  -- Change faction attributes.-  | UpdQuitFaction !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status)-  | UpdLeadFaction !FactionId !(Maybe ActorId) !(Maybe ActorId)-  | UpdDiplFaction !FactionId !FactionId !Diplomacy !Diplomacy-  | UpdAutoFaction !FactionId !Bool-  | UpdRecordKill !ActorId !(Kind.Id ItemKind) !Int-  -- Alter map.-  | UpdAlterTile !LevelId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)-  | UpdAlterClear !LevelId !Int-  | UpdSearchTile !ActorId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)-  | UpdLearnSecrets !ActorId !Int !Int-  | UpdSpotTile !LevelId ![(Point, Kind.Id TileKind)]-  | UpdLoseTile !LevelId ![(Point, Kind.Id TileKind)]-  | UpdAlterSmell !LevelId !Point !(Maybe Time) !(Maybe Time)-  | UpdSpotSmell !LevelId ![(Point, Time)]-  | UpdLoseSmell !LevelId ![(Point, Time)]-  -- Assorted.-  | UpdAgeGame !(Delta Time) ![LevelId]-  | UpdDiscover !LevelId !Point !ItemId !(Kind.Id ItemKind) !ItemSeed-  | UpdCover !LevelId !Point !ItemId !(Kind.Id ItemKind) !ItemSeed-  | UpdDiscoverKind !LevelId !Point !ItemId !(Kind.Id ItemKind)-  | UpdCoverKind !LevelId !Point !ItemId !(Kind.Id ItemKind)-  | UpdDiscoverSeed !LevelId !Point !ItemId !ItemSeed-  | UpdCoverSeed !LevelId !Point !ItemId !ItemSeed-  | UpdPerception !LevelId !Perception !Perception-  | UpdRestart !FactionId !Discovery !FactionPers !State !DebugModeCli !Text-  | UpdRestartServer !State-  | UpdResume !FactionId !FactionPers-  | UpdResumeServer !State-  | UpdKillExit !FactionId-  | UpdSaveBkp-  | UpdMsgAll !Msg-  | UpdRecordHistory !FactionId-  deriving (Show, Eq, Generic)--instance Binary UpdAtomic---- | Abstract syntax of atomic special effects.-data SfxAtomic =-    SfxStrike !ActorId !ActorId !ItemId !HitAtomic-  | SfxRecoil !ActorId !ActorId !ItemId !HitAtomic-  | SfxProject !ActorId !ItemId-  | SfxCatch !ActorId !ItemId-  | SfxActivate !ActorId !ItemId !Int-  | SfxCheck !ActorId !ItemId !Int-  | SfxTrigger !ActorId !Point !F.Feature-  | SfxShun !ActorId !Point !F.Feature-  | SfxEffect !FactionId !ActorId !(Effect.Effect Int)-  | SfxMsgFid !FactionId !Msg-  | SfxMsgAll !Msg-  | SfxActorStart !ActorId-  deriving (Show, Eq, Generic)--instance Binary SfxAtomic--data HitAtomic = HitClear | HitBlock !Int-  deriving (Show, Eq, Generic)--instance Binary HitAtomic--undoUpdAtomic :: UpdAtomic -> Maybe UpdAtomic-undoUpdAtomic cmd = case cmd of-  UpdCreateActor aid body ais -> Just $ UpdDestroyActor aid body ais-  UpdDestroyActor aid body ais -> Just $ UpdCreateActor aid body ais-  UpdCreateItem iid item k c -> Just $ UpdDestroyItem iid item k c-  UpdDestroyItem iid item k c -> Just $ UpdCreateItem iid item k c-  UpdSpotActor aid body ais -> Just $ UpdLoseActor aid body ais-  UpdLoseActor aid body ais -> Just $ UpdSpotActor aid body ais-  UpdSpotItem iid item k c -> Just $ UpdLoseItem iid item k c-  UpdLoseItem iid item k c -> Just $ UpdSpotItem iid item k c-  UpdMoveActor aid fromP toP -> Just $ UpdMoveActor aid toP fromP-  UpdWaitActor aid toWait -> Just $ UpdWaitActor aid (not toWait)-  UpdDisplaceActor source target -> Just $ UpdDisplaceActor target source-  UpdMoveItem iid k aid c1 c2 -> Just $ UpdMoveItem iid k aid c2 c1-  UpdAgeActor aid delta -> Just $ UpdAgeActor aid (timeDeltaReverse delta)-  UpdRefillHP aid n -> Just $ UpdRefillHP aid (-n)-  UpdRefillCalm aid n -> Just $ UpdRefillCalm aid (-n)-  UpdOldFidActor aid fromFid toFid -> Just $ UpdOldFidActor aid toFid fromFid-  UpdTrajectory aid fromT toT -> Just $ UpdTrajectory aid toT fromT-  UpdColorActor aid fromCol toCol -> Just $ UpdColorActor aid toCol fromCol-  UpdQuitFaction fid mb fromSt toSt -> Just $ UpdQuitFaction fid mb toSt fromSt-  UpdLeadFaction fid source target -> Just $ UpdLeadFaction fid target source-  UpdDiplFaction fid1 fid2 fromDipl toDipl ->-    Just $ UpdDiplFaction fid1 fid2 toDipl fromDipl-  UpdAutoFaction fid st -> Just $ UpdAutoFaction fid (not st)-  UpdRecordKill aid ikind k -> Just $ UpdRecordKill aid ikind (-k)-  UpdAlterTile lid p fromTile toTile ->-    Just $ UpdAlterTile lid p toTile fromTile-  UpdAlterClear lid delta -> Just $ UpdAlterClear lid (-delta)-  UpdSearchTile aid p fromTile toTile ->-    Just $ UpdSearchTile aid p toTile fromTile-  UpdLearnSecrets aid fromS toS -> Just $ UpdLearnSecrets aid toS fromS-  UpdSpotTile lid ts -> Just $ UpdLoseTile lid ts-  UpdLoseTile lid ts -> Just $ UpdSpotTile lid ts-  UpdAlterSmell lid p fromSm toSm -> Just $ UpdAlterSmell lid p toSm fromSm-  UpdSpotSmell lid sms -> Just $ UpdLoseSmell lid sms-  UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms-  UpdAgeGame delta lids -> Just $ UpdAgeGame (timeDeltaReverse delta) lids-  UpdDiscover lid p iid ik seed -> Just $ UpdCover lid p iid ik seed-  UpdCover lid p iid ik seed -> Just $ UpdDiscover lid p iid ik seed-  UpdDiscoverKind lid p iid ik -> Just $ UpdCoverKind lid p iid ik-  UpdCoverKind lid p iid ik -> Just $ UpdDiscoverKind lid p iid ik-  UpdDiscoverSeed lid p iid seed -> Just $ UpdCoverSeed lid p iid seed-  UpdCoverSeed lid p iid seed -> Just $ UpdDiscoverSeed lid p iid seed-  UpdPerception lid outPer inPer -> Just $ UpdPerception lid inPer outPer-  UpdRestart{} -> Just cmd  -- here history ends; change direction-  UpdRestartServer{} -> Just cmd  -- here history ends; change direction-  UpdResume{} -> Nothing-  UpdResumeServer{} -> Nothing-  UpdKillExit{} -> Nothing-  UpdSaveBkp -> Nothing-  UpdMsgAll{} -> Nothing  -- only generated by @cmdAtomicFilterCli@-  UpdRecordHistory{} -> Just cmd--undoSfxAtomic :: SfxAtomic -> SfxAtomic-undoSfxAtomic cmd = case cmd of-  SfxStrike source target iid b -> SfxRecoil source target iid b-  SfxRecoil source target iid b -> SfxStrike source target iid b-  SfxProject aid iid -> SfxCatch aid iid-  SfxCatch aid iid -> SfxProject aid iid-  SfxActivate aid iid k -> SfxCheck aid iid k-  SfxCheck aid iid k -> SfxActivate aid iid k-  SfxTrigger aid p feat -> SfxShun aid p feat-  SfxShun aid p feat -> SfxTrigger aid p feat-  SfxEffect{} -> cmd  -- not ideal?-  SfxMsgFid{} -> cmd-  SfxMsgAll{} -> cmd-  SfxActorStart{} -> cmd--undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic-undoCmdAtomic (UpdAtomic cmd) = fmap UpdAtomic $ undoUpdAtomic cmd-undoCmdAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx
− Game/LambdaHack/Atomic/HandleAtomicWrite.hs 
@@ -1,445 +0,0 @@--- | Semantics of atomic commands shared by client and server.--- See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Atomic.HandleAtomicWrite-  ( handleCmdAtomic-  ) where--import Control.Arrow (second)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Int (Int64)-import Data.List-import Data.Maybe--import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Atomic.MonadStateWrite-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind as ModeKind-import Game.LambdaHack.Content.TileKind as TileKind---- | The game-state semantics of atomic game commands.--- Special effects (@SfxAtomic@) don't modify state.-handleCmdAtomic :: MonadStateWrite m => CmdAtomic -> m ()-handleCmdAtomic cmd = case cmd of-  UpdAtomic upd -> handleUpdAtomic upd-  SfxAtomic _ -> return ()--handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()-handleUpdAtomic cmd = case cmd of-  UpdCreateActor aid body ais -> updCreateActor aid body ais-  UpdDestroyActor aid body ais -> updDestroyActor aid body ais-  UpdCreateItem iid item k c -> updCreateItem iid item k c-  UpdDestroyItem iid item k c -> updDestroyItem iid item k c-  UpdSpotActor aid body ais -> updCreateActor aid body ais-  UpdLoseActor aid body ais -> updDestroyActor aid body ais-  UpdSpotItem iid item k c -> updCreateItem iid item k c-  UpdLoseItem iid item k c -> updDestroyItem iid item k c-  UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP-  UpdWaitActor aid toWait -> updWaitActor aid toWait-  UpdDisplaceActor source target -> updDisplaceActor source target-  UpdMoveItem iid k aid c1 c2 -> updMoveItem iid k aid c1 c2-  UpdAgeActor aid t -> updAgeActor aid t-  UpdRefillHP aid n -> updRefillHP aid n-  UpdRefillCalm aid n -> updRefillCalm aid n-  UpdOldFidActor aid fromFid toFid -> updOldFidActor aid fromFid toFid-  UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT-  UpdColorActor aid fromCol toCol -> updColorActor aid fromCol toCol-  UpdQuitFaction fid mbody fromSt toSt -> updQuitFaction fid mbody fromSt toSt-  UpdLeadFaction fid source target -> updLeadFaction fid source target-  UpdDiplFaction fid1 fid2 fromDipl toDipl ->-    updDiplFaction fid1 fid2 fromDipl toDipl-  UpdAutoFaction fid st -> updAutoFaction fid st-  UpdRecordKill aid ikind k -> updRecordKill aid ikind k-  UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile-  UpdAlterClear lid delta -> updAlterClear lid delta-  UpdSearchTile _ _ fromTile toTile ->-    assert (fromTile /= toTile) $ return ()  -- only for clients-  UpdLearnSecrets aid fromS toS -> updLearnSecrets aid fromS toS-  UpdSpotTile lid ts -> updSpotTile lid ts-  UpdLoseTile lid ts -> updLoseTile lid ts-  UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm-  UpdSpotSmell lid sms -> updSpotSmell lid sms-  UpdLoseSmell lid sms -> updLoseSmell lid sms-  UpdAgeGame t lids -> updAgeGame t lids-  UpdDiscover{} -> return ()      -- We can't keep dicovered data in State,-  UpdCover{} -> return ()         -- because server saves all atomic commands-  UpdDiscoverKind{} -> return ()  -- to apply their inverses for undo,-  UpdCoverKind{} -> return ()     -- so they would wipe out server knowledge.-  UpdDiscoverSeed{} -> return ()-  UpdCoverSeed{} -> return ()-  UpdPerception _ outPer inPer ->-    assert (not (nullPer outPer && nullPer inPer)) skip-  UpdRestart _ _ _ s _ _ -> updRestart s-  UpdRestartServer s -> updRestartServer s-  UpdResume{} -> return ()-  UpdResumeServer s -> updResumeServer s-  UpdKillExit{} -> return ()-  UpdSaveBkp -> return ()-  UpdMsgAll{} -> return ()-  UpdRecordHistory{} -> return ()---- | Creates an actor. Note: after this command, usually a new leader--- for the party should be elected (in case this actor is the only one alive).-updCreateActor :: MonadStateWrite m-               => ActorId -> Actor -> [(ItemId, Item)] -> m ()-updCreateActor aid body ais = do-  -- Add actor to @sactorD@.-  let f Nothing = Just body-      f (Just b) = assert `failure` "actor already added"-                          `twith` (aid, body, b)-  modifyState $ updateActorD $ EM.alter f aid-  -- Add actor to @sprio@.-  let g Nothing = Just [aid]-      g (Just l) = assert (aid `notElem` l `blame` "actor already added"-                                           `twith` (aid, body, l))-                   $ Just $ aid : l-  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)-  -- Actor's items may or may not be already present in @sitemD@,-  -- regardless if they are already present otherwise in the dungeon.-  -- We re-add them all to save time determining which really need it.-  forM_ ais $ \(iid, item) -> do-    let h item1 item2 =-          assert (item1 == item2 `blame` "inconsistent created actor items"-                                 `twith` (aid, body, iid, item1, item2)) item1-    modifyState $ updateItemD $ EM.insertWith h iid item---- | Kills an actor.-updDestroyActor :: MonadStateWrite m-                => ActorId -> Actor -> [(ItemId, Item)] -> m ()-updDestroyActor aid body ais = do-  -- If a leader dies, a new leader should be elected on the server-  -- before this command is executed.-  -- TODO: check this only on the server (e.g., not in LoseActor):-  -- fact <- getsState $ (EM.! bfid body) . sfactionD-  -- assert (Just aid /= gleader fact `blame` (aid, body, fact)) skip-  -- Assert that actor's items belong to @sitemD@. Do not remove those-  -- that do not appear anywhere else, for simplicity and speed.-  itemD <- getsState sitemD-  let match (iid, item) = itemD EM.! iid == item-  assert (allB match ais `blame` "destroyed actor items not found"-                         `twith` (aid, body, ais, itemD)) skip-  -- Remove actor from @sactorD@.-  let f Nothing = assert `failure` "actor already removed" `twith` (aid, body)-      f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body"-                                     `twith` (aid, body, b)) Nothing-  modifyState $ updateActorD $ EM.alter f aid-  -- Remove actor from @sprio@.-  let g Nothing = assert `failure` "actor already removed" `twith` (aid, body)-      g (Just l) = assert (aid `elem` l `blame` "actor already removed"-                                        `twith` (aid, body, l))-                   $ let l2 = delete aid l-                     in if null l2 then Nothing else Just l2-  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)---- | Create a few copies of an item that is already registered for the dungeon--- (in @sitemRev@ field of @StateServer@).-updCreateItem :: MonadStateWrite m-              => ItemId -> Item -> Int -> Container -> m ()-updCreateItem iid item k c = assert (k > 0) $ do-  -- The item may or may not be already present in @sitemD@,-  -- regardless if it's actually present in the dungeon.-  let f item1 item2 = assert (item1 == item2-                              `blame` "inconsistent created item"-                              `twith` (iid, item, k, c)) item1-  modifyState $ updateItemD $ EM.insertWith f iid item-  insertItemContainer iid k c---- | Destroy some copies (possibly not all) of an item.-updDestroyItem :: MonadStateWrite m-               => ItemId -> Item -> Int -> Container -> m ()-updDestroyItem iid item k c = assert (k > 0) $ do-  -- Do not remove the item from @sitemD@ nor from @sitemRev@,-  -- It's incredibly costly and not noticeable for the player.-  -- However, assert the item is registered in @sitemD@.-  itemD <- getsState sitemD-  assert (iid `EM.lookup` itemD == Just item `blame` "item already removed"-                                             `twith` (iid, item, itemD)) skip-  deleteItemContainer iid k c--updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m ()-updMoveActor aid fromP toP = assert (fromP /= toP) $ do-  b <- getsState $ getActorBody aid-  assert (fromP == bpos b `blame` "unexpected moved actor position"-                          `twith` (aid, fromP, toP, bpos b, b)) skip-  updateActor aid $ \body -> body {bpos = toP, boldpos = fromP}--updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m ()-updWaitActor aid toWait = do-  b <- getsState $ getActorBody aid-  assert (toWait /= bwait b `blame` "unexpected waited actor time"-                            `twith` (aid, toWait, bwait b, b)) skip-  updateActor aid $ \body -> body {bwait = toWait}--updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()-updDisplaceActor source target = assert (source /= target) $ do-  spos <- getsState $ bpos . getActorBody source-  tpos <- getsState $ bpos . getActorBody target-  updateActor source $ \b -> b {bpos = tpos, boldpos = spos}-  updateActor target $ \b -> b {bpos = spos, boldpos = tpos}--updMoveItem :: MonadStateWrite m-            => ItemId -> Int -> ActorId -> CStore -> CStore-            -> m ()-updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do-  deleteItemActor iid k aid c1-  insertItemActor iid k aid c2---- TODO: optimize (a single call to updatePrio is enough)-updAgeActor :: MonadStateWrite m => ActorId -> Delta Time -> m ()-updAgeActor aid delta = assert (delta /= Delta timeZero) $ do-  body <- getsState $ getActorBody aid-  ais <- getsState $ getCarriedAssocs body-  updDestroyActor aid body ais-  let newBody = body {btime = timeShift (btime body) delta}-  updCreateActor aid newBody ais--updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()-updRefillHP aid n =-  updateActor aid $ \b ->-    b { bhp = bhp b + n-      , bhpDelta = let oldD = bhpDelta b-                   in if n == 0-                      then ResDelta { resCurrentTurn = 0-                                    , resPreviousTurn = resCurrentTurn oldD }-                      else oldD {resCurrentTurn = resCurrentTurn oldD + n}-      }--updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()-updRefillCalm aid n =-  updateActor aid $ \b ->-    b { bcalm = max 0 $ bcalm b + n-      , bcalmDelta = let oldD = bcalmDelta b-                     in if n == 0-                        then ResDelta { resCurrentTurn = 0-                                      , resPreviousTurn = resCurrentTurn oldD }-                        else oldD {resCurrentTurn = resCurrentTurn oldD + n}-      }--updOldFidActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m ()-updOldFidActor aid fromFid toFid = assert (fromFid /= toFid) $ do-  updateActor aid $ \b ->-    assert (boldfid b == fromFid `blame` (aid, fromFid, toFid, b))-    $ b {boldfid = toFid}--updTrajectory :: MonadStateWrite m-              => ActorId-              -> Maybe ([Vector], Speed)-              -> Maybe ([Vector], Speed)-              -> m ()-updTrajectory aid fromT toT = assert (fromT /= toT) $ do-  body <- getsState $ getActorBody aid-  assert (fromT == btrajectory body `blame` "unexpected actor trajectory"-                                    `twith` (aid, fromT, toT, body)) skip-  updateActor aid $ \b -> b {btrajectory = toT}--updColorActor :: MonadStateWrite m-              => ActorId -> Color.Color -> Color.Color -> m ()-updColorActor aid fromCol toCol = assert (fromCol /= toCol) $ do-  body <- getsState $ getActorBody aid-  assert (fromCol == bcolor body `blame` "unexpected actor color"-                                 `twith` (aid, fromCol, toCol, body)) skip-  updateActor aid $ \b -> b {bcolor = toCol}--updQuitFaction :: MonadStateWrite m-               => FactionId -> Maybe Actor -> Maybe Status -> Maybe Status-               -> m ()-updQuitFaction fid mbody fromSt toSt = do-  assert (fromSt /= toSt `blame` (fid, mbody, fromSt, toSt)) skip-  assert (maybe True ((fid ==) . bfid) mbody) skip-  fact <- getsState $ (EM.! fid) . sfactionD-  assert (fromSt == gquit fact `blame` "unexpected actor quit status"-                               `twith` (fid, fromSt, toSt, fact)) skip-  let adj fa = fa {gquit = toSt}-  updateFaction fid adj---- The previous leader is assumed to be alive.-updLeadFaction :: MonadStateWrite m-               => FactionId -> Maybe ActorId -> Maybe ActorId -> m ()-updLeadFaction fid source target = assert (source /= target) $ do-  fact <- getsState $ (EM.! fid) . sfactionD-  assert (playerLeader $ gplayer fact) skip  -- @PosNone@ ensure this-  mtb <- getsState $ \s -> fmap (flip getActorBody s) target-  assert (maybe True (not . bproj) mtb-          `blame` (fid, source, target, mtb, fact)) skip-  assert (source == gleader fact-          `blame` "unexpected actor leader"-          `twith` (fid, source, target, mtb, fact)) skip-  let adj fa = fa {gleader = target}-  updateFaction fid adj--updDiplFaction :: MonadStateWrite m-               => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()-updDiplFaction fid1 fid2 fromDipl toDipl =-  assert (fid1 /= fid2 && fromDipl /= toDipl) $ do-    fact1 <- getsState $ (EM.! fid1) . sfactionD-    fact2 <- getsState $ (EM.! fid2) . sfactionD-    assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1)-            && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2)-            `blame` "unexpected actor diplomacy status"-            `twith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) skip-    let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}-    updateFaction fid1 (adj fid2)-    updateFaction fid2 (adj fid1)--updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()-updAutoFaction fid st = do-  let adj fact =-        let player = gplayer fact-        in assert (playerAI player == not st)-           $ fact {gplayer = player {playerAI = st}}-  updateFaction fid adj---- | Record a given number (usually just 1, or -1 for undo) of actor kills--- for score calculation.-updRecordKill :: MonadStateWrite m => ActorId -> Kind.Id ItemKind -> Int -> m ()-updRecordKill aid ikind k = do-  b <- getsState $ getActorBody aid-  assert (not (bproj b) `blame` (aid, b)) skip-  let alterKind mn = let n = fromMaybe 0 mn + k-                     in if n == 0 then Nothing else Just n-      adjFact fact = fact {gvictims = EM.alter alterKind ikind-                                      $ gvictims fact}-  updateFaction (bfid b) adjFact---- | Alter an attribute (actually, the only, the defining attribute)--- of a visible tile. This is similar to e.g., @UpdTrajectory@.-updAlterTile :: MonadStateWrite m-             => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind-             -> m ()-updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do-  Kind.COps{cotile} <- getsState scops-  lvl <- getLevel lid-  -- The second alternative below can happen if, e.g., a client remembers,-  -- but does not see the tile (so does not notice the SearchTile action),-  -- and it suddenly changes into another tile,-  -- which at the same time becomes visible (e.g., an open door).-  let adj ts = assert (ts PointArray.! p == fromTile-                       || ts PointArray.! p == Tile.hideAs cotile fromTile-                       `blame` "unexpected altered tile kind"-                       `twith` (lid, p, fromTile, toTile, ts PointArray.! p))-               $ ts PointArray.// [(p, toTile)]-  updateLevel lid $ updateTile adj-  case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of-    (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}-    (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}-    _ -> return ()--updAlterClear :: MonadStateWrite m => LevelId -> Int -> m ()-updAlterClear lid delta = assert (delta /= 0) $-  updateLevel lid $ \lvl -> lvl {lclear = lclear lvl + delta}---- TODO: use instead of revealing all secret positions initially, at once--- in Common/State.hs.-updLearnSecrets :: MonadStateWrite m => ActorId -> Int -> Int -> m ()-updLearnSecrets aid fromS toS = assert (fromS /= toS) $ do-  b <- getsState $ getActorBody aid-  updateLevel (blid b) $ \lvl -> assert (lsecret lvl == fromS)-                                 $ lvl {lsecret = toS}---- Notice previously invisible tiles. This is similar to @UpdSpotActor@,--- but done in bulk, because it often involves dozens of tiles pers move.--- We don't check that the tiles at the positions in question are unknown--- to save computation, especially for clients that remember tiles--- at previously seen positions. Similarly, when updating the @lseen@--- field we don't assume the tiles were unknown previously.-updSpotTile :: MonadStateWrite m-            => LevelId -> [(Point, Kind.Id TileKind)] -> m ()-updSpotTile lid ts = assert (not $ null ts) $ do-  Kind.COps{cotile} <- getsState scops-  Level{ltile} <- getLevel lid-  let adj tileMap = tileMap PointArray.// ts-  updateLevel lid $ updateTile adj-  let f (p, t2) = do-        let t1 = ltile PointArray.! p-        case (Tile.isExplorable cotile t1, Tile.isExplorable cotile t2) of-          (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1}-          (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1}-          _ -> return ()-  mapM_ f ts---- Stop noticing previously visible tiles. Unlike @updSpotActor@, it verifies--- the state of the tiles before changing them.-updLoseTile :: MonadStateWrite m-            => LevelId -> [(Point, Kind.Id TileKind)] -> m ()-updLoseTile lid ts = assert (not $ null ts) $ do-  Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops-  let unknownId = ouniqGroup "unknown space"-      matches _ [] = True-      matches tileMap ((p, ov) : rest) =-        tileMap PointArray.! p == ov && matches tileMap rest-      tu = map (second (const unknownId)) ts-      adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu-  updateLevel lid $ updateTile adj-  let f (_, t1) =-        when (Tile.isExplorable cotile t1) $-          updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}-  mapM_ f ts--updAlterSmell :: MonadStateWrite m-            => LevelId -> Point -> Maybe Time -> Maybe Time -> m ()-updAlterSmell lid p fromSm toSm = do-  let alt sm = assert (sm == fromSm `blame` "unexpected tile smell"-                                    `twith` (lid, p, fromSm, toSm, sm)) toSm-  updateLevel lid $ updateSmell $ EM.alter alt p--updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()-updSpotSmell lid sms = assert (not $ null sms) $ do-  let alt sm Nothing = Just sm-      alt sm (Just oldSm) = assert `failure` "smell already added"-                                   `twith` (lid, sms, sm, oldSm)-      f (p, sm) = EM.alter (alt sm) p-      upd m = foldr f m sms-  updateLevel lid $ updateSmell upd--updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()-updLoseSmell lid sms = assert (not $ null sms) $ do-  let alt sm Nothing = assert `failure` "smell already removed"-                              `twith` (lid, sms, sm)-      alt sm (Just oldSm) =-        assert (sm == oldSm `blame` "unexpected lost smell"-                            `twith` (lid, sms, sm, oldSm)) Nothing-      f (p, sm) = EM.alter (alt sm) p-      upd m = foldr f m sms-  updateLevel lid $ updateSmell upd---- | Age the game.------ TODO: It leaks information that there is activity on various level,--- even if the faction has no actors there, so show this on UI somewhere,--- e.g., in the @~@ menu of seen level indicate recent activity.-updAgeGame :: MonadStateWrite m => Delta Time -> [LevelId] -> m ()-updAgeGame delta lids = assert (delta /= Delta timeZero) $ do-  modifyState $ updateTime $ flip timeShift delta-  mapM_ (ageLevel delta) lids--ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m ()-ageLevel delta lid =-  updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta}--updRestart :: MonadStateWrite m-           => State -> m ()-updRestart = putState--updRestartServer :: MonadStateWrite m => State -> m ()-updRestartServer = putState--updResumeServer :: MonadStateWrite m => State -> m ()-updResumeServer = putState
− Game/LambdaHack/Atomic/MonadAtomic.hs 
@@ -1,31 +0,0 @@--- | Atomic monads.-module Game.LambdaHack.Atomic.MonadAtomic-  ( MonadAtomic(..)-  , broadcastUpdAtomic,  broadcastSfxAtomic-  ) where--import Data.Key (mapWithKeyM_)--import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.State--class MonadStateRead m => MonadAtomic m where-  execAtomic    :: CmdAtomic -> m ()-  execUpdAtomic :: UpdAtomic -> m ()-  execUpdAtomic = execAtomic . UpdAtomic-  execSfxAtomic :: SfxAtomic -> m ()-  execSfxAtomic = execAtomic . SfxAtomic--broadcastUpdAtomic :: MonadAtomic m-                   => (FactionId -> UpdAtomic) -> m ()-broadcastUpdAtomic fcmd = do-  factionD <- getsState sfactionD-  mapWithKeyM_ (\fid _ -> execUpdAtomic $ fcmd fid) factionD--broadcastSfxAtomic :: MonadAtomic m-                   => (FactionId -> SfxAtomic) -> m ()-broadcastSfxAtomic fcmd = do-  factionD <- getsState sfactionD-  mapWithKeyM_ (\fid _ -> execSfxAtomic $ fcmd fid) factionD
− Game/LambdaHack/Atomic/MonadStateWrite.hs 
@@ -1,168 +0,0 @@--- | The monad for writing to the game state and related operations.-module Game.LambdaHack.Atomic.MonadStateWrite-  ( MonadStateWrite(..)-  , updateLevel, updateActor, updateFaction-  , insertItemContainer, insertItemActor, deleteItemContainer, deleteItemActor-  , updatePrio, updateFloor, updateTile, updateSmell-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State--class MonadStateRead m => MonadStateWrite m where-  modifyState :: (State -> State) -> m ()-  putState    :: State -> m ()---- | Update the actor time priority queue.-updatePrio :: (ActorPrio -> ActorPrio) -> Level -> Level-updatePrio f lvl = lvl {lprio = f (lprio lvl)}---- | Update the items on the ground map.-updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level-updateFloor f lvl = lvl {lfloor = f (lfloor lvl)}---- | Update the tile map.-updateTile :: (TileMap -> TileMap) -> Level -> Level-updateTile f lvl = lvl {ltile = f (ltile lvl)}---- | Update the smell map.-updateSmell :: (SmellMap -> SmellMap) -> Level -> Level-updateSmell f lvl = lvl {lsmell = f (lsmell lvl)}---- | Update a given level data within state.-updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m ()-updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid--updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()-updateActor aid f = do-  let alt Nothing = assert `failure` "no body to update" `twith` aid-      alt (Just b) = Just $ f b-  modifyState $ updateActorD $ EM.alter alt aid--updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m ()-updateFaction fid f = do-  let alt Nothing = assert `failure` "no faction to update" `twith` fid-      alt (Just fact) = Just $ f fact-  modifyState $ updateFactionD $ EM.alter alt fid--insertItemContainer :: MonadStateWrite m-                    => ItemId -> Int -> Container -> m ()-insertItemContainer iid k c = case c of-  CFloor lid pos -> insertItemFloor iid k lid pos-  CActor aid store -> insertItemActor iid k aid store-  CTrunk{} -> return ()--insertItemFloor :: MonadStateWrite m-                => ItemId -> Int -> LevelId -> Point -> m ()-insertItemFloor iid k lid pos =-  let bag = EM.singleton iid k-      mergeBag = EM.insertWith (EM.unionWith (+)) pos bag-  in updateLevel lid $ updateFloor mergeBag--insertItemActor :: MonadStateWrite m-                => ItemId -> Int -> ActorId -> CStore -> m ()-insertItemActor iid k aid cstore = case cstore of-  CGround -> do-    b <- getsState $ getActorBody aid-    insertItemFloor iid k (blid b) (bpos b)-  COrgan -> insertItemBody iid k aid-  CEqp -> insertItemEqp iid k aid-  CInv -> insertItemInv iid k aid-  CSha -> do-    b <- getsState $ getActorBody aid-    insertItemSha iid k (bfid b)--insertItemBody :: MonadStateWrite m-               => ItemId -> Int -> ActorId -> m ()-insertItemBody iid k aid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag-  updateActor aid $ \b -> b {borgan = upd (borgan b)}--insertItemEqp :: MonadStateWrite m-              => ItemId -> Int -> ActorId -> m ()-insertItemEqp iid k aid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag-  updateActor aid $ \b -> b {beqp = upd (beqp b)}--insertItemInv :: MonadStateWrite m-              => ItemId -> Int -> ActorId -> m ()-insertItemInv iid k aid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag-  updateActor aid $ \b -> b {binv = upd (binv b)}--insertItemSha :: MonadStateWrite m-               => ItemId -> Int -> FactionId -> m ()-insertItemSha iid k fid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag-  updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)}--deleteItemContainer :: MonadStateWrite m-                    => ItemId -> Int -> Container -> m ()-deleteItemContainer iid k c = case c of-  CFloor lid pos -> deleteItemFloor iid k lid pos-  CActor aid store -> deleteItemActor iid k aid store-  CTrunk{} -> return ()--deleteItemFloor :: MonadStateWrite m-                => ItemId -> Int -> LevelId -> Point -> m ()-deleteItemFloor iid k lid pos =-  let rmFromFloor (Just bag) =-        let nbag = rmFromBag k iid bag-        in if EM.null nbag then Nothing else Just nbag-      rmFromFloor Nothing = assert `failure` "item already removed"-                                   `twith` (iid, k, lid, pos)-  in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos--deleteItemActor :: MonadStateWrite m-                => ItemId -> Int -> ActorId -> CStore -> m ()-deleteItemActor iid k aid cstore = case cstore of-  CGround -> do-    b <- getsState $ getActorBody aid-    deleteItemFloor iid k (blid b) (bpos b)-  COrgan -> deleteItemBody iid k aid-  CEqp -> deleteItemEqp iid k aid-  CInv -> deleteItemInv iid k aid-  CSha -> do-    b <- getsState $ getActorBody aid-    deleteItemSha iid k (bfid b)--deleteItemBody :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()-deleteItemBody iid k aid = do-  updateActor aid $ \b -> b {borgan = rmFromBag k iid (borgan b) }--deleteItemEqp :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()-deleteItemEqp iid k aid = do-  updateActor aid $ \b -> b {beqp = rmFromBag k iid (beqp b)}--deleteItemInv :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()-deleteItemInv iid k aid = do-  updateActor aid $ \b -> b {binv = rmFromBag k iid (binv b)}--deleteItemSha :: MonadStateWrite m => ItemId -> Int -> FactionId -> m ()-deleteItemSha iid k fid = do-  updateFaction fid $ \fact -> fact {gsha = rmFromBag k iid (gsha fact)}--rmFromBag :: Int -> ItemId -> ItemBag -> ItemBag-rmFromBag k iid bag =-  let rfb Nothing = assert `failure` "rm from empty slot" `twith` (k, iid, bag)-      rfb (Just n) =-        case compare n k of-          LT -> assert `failure` "rm more than there is"-                       `twith` (n, k, iid, bag)-          EQ -> Nothing-          GT -> Just (n - k)-  in EM.alter rfb iid bag
− Game/LambdaHack/Atomic/PosAtomicRead.hs 
@@ -1,329 +0,0 @@--- | Semantics of atomic commands shared by client and server.--- See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Atomic.PosAtomicRead-  ( PosAtomic(..), posUpdAtomic, posSfxAtomic-  , resetsFovCmdAtomic, breakUpdAtomic, breakSfxAtomic, loudUpdAtomic-  , seenAtomicCli, seenAtomicSer, generalMoveItem-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.ModeKind as ModeKind---- All functions here that take an atomic action are executed--- in the state just before the action is executed.---- | The type representing visibility of actions to factions,--- based on the position of the action, etc.-data PosAtomic =-    PosSight !LevelId ![Point]  -- ^ whomever sees all the positions, notices-  | PosFidAndSight !FactionId !LevelId ![Point]-                                -- ^ observers and the faction notice-  | PosSmell !LevelId ![Point]  -- ^ whomever smells all the positions, notices-  | PosFid !FactionId           -- ^ only the faction notices-  | PosFidAndSer !(Maybe LevelId) !FactionId  -- ^ faction and server notices-  | PosSer                      -- ^ only the server notices-  | PosAll                      -- ^ everybody notices-  | PosNone                     -- ^ never broadcasted, but sent manually-  deriving (Show, Eq)---- | Produce the positions where the action takes place. If a faction--- is returned, the action is visible only for that faction, if Nothing--- is returned, it's never visible. Empty list of positions implies--- the action is visible always.------ The goal of the mechanics: client should not get significantly--- more information by looking at the atomic commands he is able to see--- than by looking at the state changes they enact. E.g., @UpdDisplaceActor@--- in a black room, with one actor carrying a 0-radius light would not be--- distinguishable by looking at the state (or the screen) from @UpdMoveActor@--- of the illuminated actor, hence such @UpdDisplaceActor@ should not be--- observable, but @UpdMoveActor@ should be (or the former should be perceived--- as the latter). However, to simplify, we assing as strict visibility--- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back--- to @UpdSpotActor@ (which provides minimal information that does not--- contradict state) if the visibility is lower.-posUpdAtomic :: MonadStateRead m => UpdAtomic -> m PosAtomic-posUpdAtomic cmd = case cmd of-  UpdCreateActor _ body _ -> posProjBody body-  UpdDestroyActor _ body _ -> posProjBody body-  UpdCreateItem _ _ _ c -> singleContainer c-  UpdDestroyItem _ _ _ c -> singleContainer c-  UpdSpotActor _ body _ -> posProjBody body-  UpdLoseActor _ body _ -> posProjBody body-  UpdSpotItem _ _ _ c -> singleContainer c-  UpdLoseItem _ _ _ c -> singleContainer c-  UpdMoveActor aid fromP toP -> do-    (lid, _) <- posOfAid aid-    return $! PosSight lid [fromP, toP]-  UpdWaitActor aid _ -> singleAid aid-  UpdDisplaceActor source target -> do-    (slid, sp) <- posOfAid source-    (tlid, tp) <- posOfAid target-    return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  UpdMoveItem _ _ aid _ CSha -> do  -- shared stash is private-    b <- getsState $ getActorBody aid-    return $! PosFidAndSer (Just $ blid b) (bfid b)-  UpdMoveItem _ _ aid CSha _ -> do  -- shared stash is private-    b <- getsState $ getActorBody aid-    return $! PosFidAndSer (Just $ blid b) (bfid b)-  UpdMoveItem _ _ aid _ _ -> singleAid aid-  UpdAgeActor aid _ -> singleAid aid-  UpdRefillHP aid _ -> singleAid aid-  UpdRefillCalm aid _ -> singleAid aid-  UpdOldFidActor aid _ _ -> singleAid aid-  UpdTrajectory aid _ _ -> singleAid aid-  UpdColorActor aid _ _ -> singleAid aid-  UpdQuitFaction{} -> return PosAll-  UpdLeadFaction fid _ _ -> do-    fact <- getsState $ (EM.! fid) . sfactionD-    return $! if playerLeader $ gplayer fact-              then PosFidAndSer Nothing fid-              else PosNone-  UpdDiplFaction{} -> return PosAll-  UpdAutoFaction{} -> return PosAll-  UpdRecordKill aid _ _ -> singleFidAndAid aid-  UpdAlterTile lid p _ _ -> return $! PosSight lid [p]-  UpdAlterClear{} -> return PosAll-  UpdSearchTile aid p _ _ -> do-    (lid, pos) <- posOfAid aid-    return $! PosSight lid [pos, p]-  UpdLearnSecrets aid _ _ -> singleAid aid-  UpdSpotTile lid ts -> do-    let ps = map fst ts-    return $! PosSight lid ps-  UpdLoseTile lid ts -> do-    let ps = map fst ts-    return $! PosSight lid ps-  UpdAlterSmell lid p _ _ -> return $! PosSmell lid [p]-  UpdSpotSmell lid sms -> do-    let ps = map fst sms-    return $! PosSmell lid ps-  UpdLoseSmell lid sms -> do-    let ps = map fst sms-    return $! PosSmell lid ps-  UpdAgeGame _ _ -> return PosAll-  UpdDiscover lid p _ _ _ -> return $! PosSight lid [p]-  UpdCover lid p _ _ _ -> return $! PosSight lid [p]-  UpdDiscoverKind lid p _ _ -> return $! PosSight lid [p]-  UpdCoverKind lid p _ _ -> return $! PosSight lid [p]-  UpdDiscoverSeed lid p _ _ -> return $! PosSight lid [p]-  UpdCoverSeed lid p _ _ -> return $! PosSight lid [p]-  UpdPerception{} -> return PosNone-  UpdRestart fid _ _ _ _ _ -> return $! PosFid fid-  UpdRestartServer _ -> return PosSer-  UpdResume fid _ -> return $! PosFid fid-  UpdResumeServer _ -> return PosSer-  UpdKillExit fid -> return $! PosFid fid-  UpdSaveBkp -> return PosAll-  UpdMsgAll{} -> return PosAll-  UpdRecordHistory fid -> return $! PosFid fid---- | Produce the positions where the atomic special effect takes place.-posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic-posSfxAtomic cmd = case cmd of-  SfxStrike source target _ _ -> do-    (slid, sp) <- posOfAid source-    (tlid, tp) <- posOfAid target-    return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  SfxRecoil source target _ _ -> do-    (slid, sp) <- posOfAid source-    (tlid, tp) <- posOfAid target-    return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  SfxProject aid _ -> singleAid aid-  SfxCatch aid _ -> singleAid aid-  SfxActivate aid _ _ -> singleAid aid-  SfxCheck aid _ _ -> singleAid aid-  SfxTrigger aid p _ -> do-    (lid, pa) <- posOfAid aid-    return $! PosSight lid [pa, p]-  SfxShun aid p _ -> do-    (lid, pa) <- posOfAid aid-    return $! PosSight lid [pa, p]-  SfxEffect _ aid _ -> singleAid aid  -- sometimes we don't see source, OK-  SfxMsgFid fid _ -> return $! PosFid fid-  SfxMsgAll _ -> return PosAll-  SfxActorStart aid -> singleAid aid--posProjBody :: Monad m => Actor -> m PosAtomic-posProjBody body = return $!-  if bproj body-  then PosSight (blid body) [bpos body]-  else PosFidAndSight (bfid body) (blid body) [bpos body]--singleFidAndAid :: MonadStateRead m => ActorId -> m PosAtomic-singleFidAndAid aid = do-  body <- getsState $ getActorBody aid-  return $! PosFidAndSight (bfid body) (blid body) [bpos body]--singleAid :: MonadStateRead m => ActorId -> m PosAtomic-singleAid aid = do-  (lid, p) <- posOfAid aid-  return $! PosSight lid [p]--singleContainer :: MonadStateRead m => Container -> m PosAtomic-singleContainer (CFloor lid p) = return $! PosSight lid [p]-singleContainer (CActor aid CSha) = do  -- shared stash is private-  b <- getsState $ getActorBody aid-  return $! PosFidAndSer (Just $ blid b) (bfid b)-singleContainer (CActor aid _) = do-  (lid, p) <- posOfAid aid-  return $! PosSight lid [p]-singleContainer (CTrunk fid lid p) = return $! PosFidAndSight fid lid [p]---- | Determines if a command resets FOV.------ Invariant: if @resetsFovCmdAtomic@ determines we do not need--- to reset Fov, perception (@ptotal@ to be precise, @psmell@ is irrelevant)--- of any faction does not change upon recomputation. Otherwise,--- save/restore would change game state.-resetsFovCmdAtomic :: UpdAtomic -> Bool-resetsFovCmdAtomic cmd = case cmd of-  -- Create/destroy actors and items.-  UpdCreateActor{} -> True  -- may have a light source-  UpdDestroyActor{} -> True-  UpdCreateItem{} -> True  -- may be a light source-  UpdDestroyItem{} -> True-  UpdSpotActor{} -> True-  UpdLoseActor{} -> True-  UpdSpotItem{} -> True-  UpdLoseItem{} -> True-  -- Move actors and items.-  UpdMoveActor{} -> True-  UpdDisplaceActor{} -> True-  UpdMoveItem{} -> True  -- light sources, sight radius bonuses-  UpdRefillCalm{} -> True  -- Calm caps sight radius-  -- Alter map.-  UpdAlterTile{} -> True  -- even if pos not visible initially-  UpdSpotTile{} -> True-  UpdLoseTile{} -> True-  _ -> False---- | Decompose an atomic action. The original action is visible--- if it's positions are visible both before and after the action--- (in between the FOV might have changed). The decomposed actions--- are only tested vs the FOV after the action and they give reduced--- information that still modifies client's state to match the server state--- wrt the current FOV and the subset of @posUpdAtomic@ that is visible.--- The original actions give more information not only due to spanning--- potentially more positions than those visible. E.g., @UpdMoveActor@--- informs about the continued existence of the actor between--- moves, v.s., popping out of existence and then back in.-breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic]-breakUpdAtomic cmd = case cmd of-  UpdMoveActor aid _ toP -> do-    b <- getsState $ getActorBody aid-    ais <- getsState $ getCarriedAssocs b-    let loseSpot = [ UpdLoseActor aid b ais-                   , UpdSpotActor aid b {bpos = toP, boldpos = bpos b} ais ]-    fact <- getsState $ (EM.! bfid b) . sfactionD-    if gleader fact == Just aid-      then return $ [UpdLeadFaction (bfid b) (Just aid) Nothing]-                    ++ loseSpot-                    ++ [UpdLeadFaction (bfid b) Nothing (Just aid)]-      else return loseSpot-  UpdDisplaceActor source target -> do-    sb <- getsState $ getActorBody source-    sais <- getsState $ getCarriedAssocs sb-    tb <- getsState $ getActorBody target-    tais <- getsState $ getCarriedAssocs tb-    return [ UpdLoseActor source sb sais-           , UpdSpotActor source sb {bpos = bpos tb, boldpos = bpos sb} sais-           , UpdLoseActor target tb tais-           , UpdSpotActor target tb {bpos = bpos sb, boldpos = bpos tb} tais-           ]-  UpdMoveItem iid k aid cstore1 cstore2 | cstore1 == CSha  -- CSha is private-                                          || cstore2 == CSha -> do-    item <- getsState $ getItemBody iid-    return [ UpdLoseItem iid item k (CActor aid cstore1)-           , UpdSpotItem iid item k (CActor aid cstore2) ]-  -- No need to cover @UpdSearchTile@, because if an actor sees only-  -- one of the positions and so doesn't notice the search results,-  -- he's left with a hidden tile, which doesn't cause any trouble-  -- (because the commands doesn't change @State@ and the client-side-  -- processing of the command is lenient).-  _ -> return [cmd]---- | Decompose an atomic special effect.-breakSfxAtomic :: MonadStateRead m => SfxAtomic -> m [SfxAtomic]-breakSfxAtomic cmd = case cmd of-  SfxStrike source target _ _ -> do-    -- Hack: make a fight detectable even if one of combatants not visible.-    sb <- getsState $ getActorBody source-    return $! [ SfxEffect (bfid sb) source (Effect.RefillCalm (-1))-              | not $ bproj sb ]-              ++ [SfxEffect (bfid sb) target (Effect.RefillHP (-1))]-  _ -> return [cmd]---- | Messages for some unseen game object creation/destruction/alteration.-loudUpdAtomic :: MonadStateRead m-              => Bool -> FactionId -> UpdAtomic -> m (Maybe Msg)-loudUpdAtomic local fid cmd = do-  msound <- case cmd of-    UpdDestroyActor _ body _-      -- Death of a party member does not need to be heard,-      -- because it's seen.-      | not $ fid == bfid body || bproj body -> return $ Just "shriek"-    UpdCreateItem{} -> return $ Just "clatter"-    UpdAlterTile _ _ fromTile _ -> do-      Kind.COps{cotile} <- getsState scops-      if Tile.isDoor cotile fromTile-        then return $ Just "creaking sound"-        else return $ Just "rumble"-    _ -> return Nothing-  let distant = if local then [] else ["distant"]-      hear sound = makeSentence [ "you hear"-                                , MU.AW $ MU.Phrase $ distant ++ [sound] ]-  return $! hear <$> msound--seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool-seenAtomicCli knowEvents fid per posAtomic =-  case posAtomic of-    PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents-    PosFidAndSight fid2 _ ps ->-      fid == fid2 || all (`ES.member` totalVisible per) ps || knowEvents-    PosSmell _ ps -> all (`ES.member` smellVisible per) ps || knowEvents-    PosFid fid2 -> fid == fid2-    PosFidAndSer _ fid2 -> fid == fid2-    PosSer -> False-    PosAll -> True-    PosNone -> assert `failure` "no position possible" `twith` fid--seenAtomicSer :: PosAtomic -> Bool-seenAtomicSer posAtomic =-  case posAtomic of-    PosFid _ -> False-    PosNone -> False-    _ -> True--generalMoveItem :: MonadStateRead m-                => ItemId -> Int -> Container -> Container-                -> m [UpdAtomic]-generalMoveItem iid k c1 c2 = do-  case (c1, c2) of-    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 -> do-      return [UpdMoveItem iid k aid1 cstore1 cstore2]-    _ -> do-      item <- getsState $ getItemBody iid-      return [ UpdLoseItem iid item k c1-             , UpdSpotItem iid item k c2 ]
− Game/LambdaHack/Client.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | Semantics of responses that are sent to clients.------ See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Client-  ( exeFrontend-  ) where--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.LoopClient-import Game.LambdaHack.Client.ProtocolClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State---- | 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, MonadClientUI m-               , MonadClientReadResponse ResponseUI m-               , MonadClientWriteRequest RequestUI m-               , MonadAtomic n-               , MonadClientReadResponse ResponseAI n-               , MonadClientWriteRequest RequestAI n )-            => (m () -> SessionUI -> State -> StateClient-                -> chanServerUI-                -> IO ())-            -> (n () -> SessionUI -> State -> StateClient-                -> chanServerAI-                -> IO ())-            -> KeyKind -> Kind.COps -> DebugModeCli-            -> ((FactionId -> chanServerUI -> IO ())-               -> (FactionId -> chanServerAI -> IO ())-               -> IO ())-            -> IO ()-exeFrontend executorUI executorAI copsClient cops sdebugCli exeServer =-  srtFrontend (executorUI . loopUI)-              (executorAI . loopAI)-              copsClient cops sdebugCli exeServer
− Game/LambdaHack/Client/AI.hs 
@@ -1,81 +0,0 @@--- | Ways for the client to use AI to produce server requests, based on--- the client's view of the game state.-module Game.LambdaHack.Client.AI-  ( -- * Public API-    queryAI, pongAI-    -- * Internal functions-  , refreshTarget, pickAction-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM-import qualified Data.Text as T--import Game.LambdaHack.Client.AI.HandleAbilityClient-import Game.LambdaHack.Client.AI.PickActorClient-import Game.LambdaHack.Client.AI.PickTargetClient-import Game.LambdaHack.Client.AI.Strategy-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request---- | Handle the move of an AI player.-queryAI :: MonadClient m => ActorId -> m RequestAI-queryAI oldAid = do-  (aidToMove, bToMove) <- pickActorToMove refreshTarget oldAid-  RequestAnyAbility reqAny <- pickAction (aidToMove, bToMove)-  let req = ReqAITimed reqAny-  if aidToMove /= oldAid-    then return $! ReqAILeader aidToMove req-    else return $! req---- | Client signals to the server that it's still online.-pongAI :: MonadClient m => m RequestAI-pongAI = return ReqAIPong--refreshTarget :: MonadClient m-              => ActorId -> (ActorId, Actor)-              -> m (Maybe ((ActorId, Actor), (Target, PathEtc)))-refreshTarget oldLeader (aid, body) = do-  side <- getsClient sside-  assert (bfid body == side `blame` "AI tries to move an enemy actor"-                            `twith` (aid, body, side)) skip-  assert (not (bproj body) `blame` "AI gets to manually move its projectiles"-                           `twith` (aid, body, side)) skip-  stratTarget <- targetStrategy oldLeader aid-  tgtMPath <--    if nullStrategy stratTarget then-      -- No sensible target; wipe out the old one.-      return Nothing-    else do-      -- Choose a target from those proposed by AI for the actor.-      tmp <- rndToAction $ frequency $ bestVariant stratTarget-      return $ Just tmp-  oldTgt <- getsClient $ EM.lookup aid . stargetD-  let _debug = T.unpack-          $ "\nHandleAI symbol:"    <+> tshow (bsymbol body)-          <> ", aid:"               <+> tshow aid-          <> ", pos:"               <+> tshow (bpos body)-          <> "\nHandleAI oldTgt:"   <+> tshow oldTgt-          <> "\nHandleAI strTgt:"   <+> tshow stratTarget-          <> "\nHandleAI target:"   <+> tshow tgtMPath---  trace _debug skip-  modifyClient $ \cli ->-    cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)}-  return $! case tgtMPath of-    Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc))-    _ -> Nothing--pickAction :: MonadClient m => (ActorId, Actor) -> m RequestAnyAbility-pickAction (aid, body) = do-  side <- getsClient sside-  assert (bfid body == side `blame` "AI tries to move enemy actor"-                            `twith` (aid, bfid body, side)) skip-  assert (not (bproj body) `blame` "AI gets to manually move its projectiles"-                           `twith` (aid, bfid body, side)) skip-  stratAction <- actionStrategy aid-  -- Run the AI: chose an action from those given by the AI strategy.-  rndToAction $ frequency $ bestVariant stratAction
− Game/LambdaHack/Client/AI/ConditionClient.hs 
@@ -1,262 +0,0 @@--- | Semantics of abilities in terms of actions and the AI procedure--- for picking the best action for an actor.-module Game.LambdaHack.Client.AI.ConditionClient-  ( condTgtEnemyPresentM-  , condTgtEnemyRememberedM-  , condAnyFoeAdjM-  , condHpTooLowM-  , condOnTriggerableM-  , condBlocksFriendsM-  , condFloorWeaponM-  , condNoEqpWeaponM-  , condCanProjectM-  , condNotCalmEnoughM-  , condDesirableFloorItemM-  , condMeleeBadM-  , condLightBetraysM-  , benAvailableItems-  , benGroundItems-  , threatDistList-  , fleeList-  ) where--import Control.Applicative-import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import Data.Ord--import Game.LambdaHack.Client.AI.Preferences-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector---- | Require that the target enemy is visible by the party.-condTgtEnemyPresentM :: MonadClient m => ActorId -> m Bool-condTgtEnemyPresentM aid = do-  btarget <- getsClient $ getTarget aid-  return $! case btarget of-    Just TEnemy{} -> True-    _ -> False---- | Require that the target enemy is remembered on the actor's level.-condTgtEnemyRememberedM :: MonadClient m => ActorId -> m Bool-condTgtEnemyRememberedM aid = do-  b <- getsState $ getActorBody aid-  btarget <- getsClient $ getTarget aid-  return $! case btarget of-    Just (TEnemyPos _ lid _ _) | lid == blid b -> True-    _ -> False---- | Require that any non-dying foe is adjacent.-condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool-condAnyFoeAdjM aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)-  return $ any (adjacent (bpos b) . bpos) allFoes  -- keep it lazy---- | Require the actor's HP is low enough.-condHpTooLowM :: MonadClient m => ActorId -> m Bool-condHpTooLowM aid = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  return $! hpTooLow b activeItems---- | Require the actor stands over a triggerable tile.-condOnTriggerableM :: MonadStateRead m => ActorId -> m Bool-condOnTriggerableM aid = do-  Kind.COps{cotile} <- getsState scops-  b <- getsState $ getActorBody aid-  lvl <- getLevel $ blid b-  let t = lvl `at` bpos b-  return $! not $ null $ Tile.causeEffects cotile t---- | Produce the chess-distance-sorted list of non-low-HP foes on the level.--- We don't consider path-distance, because we are interested in how soon--- the foe can hit us, which can diverge greately from path distance--- for short distances.-threatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]-threatDistList aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  let strongActor (aid2, b2) = do-        activeItems <- activeItemsClient aid2-        return $! not $ hpTooLow b2 activeItems-  allThreats <- filterM strongActor allAtWar-  let addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2))-  return $ sortBy (comparing fst) $ map addDist allThreats---- | Require the actor blocks the paths of any of his party members.-condBlocksFriendsM :: MonadClient m => ActorId -> m Bool-condBlocksFriendsM aid = do-  b <- getsState $ getActorBody aid-  ours <- getsState $ actorRegularAssocs (== bfid b) (blid b)-  targetD <- getsClient stargetD-  let blocked (aid2, _) = aid2 /= aid &&-        case EM.lookup aid2 targetD of-          Just (_, Just (_ : q : _, _)) | q == bpos b -> True-          _ -> False-  return $ any blocked ours  -- keep it lazy---- | Require the actor stands over a weapon.-condFloorWeaponM :: MonadClient m => ActorId -> m Bool-condFloorWeaponM aid = do-  floorAssocs <- fullAssocsClient aid [CGround]-  -- We do consider OFF weapons, because e.g., enemies might have turned-  -- them off or they can be wrong for other party members, but are OK for us.-  let lootIsWeapon =-        not $ null $ strongestSlot Effect.EqpSlotWeapon floorAssocs-  return $ lootIsWeapon  -- keep it lazy---- | Check whether the actor has no weapon in equipment.-condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool-condNoEqpWeaponM aid = do-  allAssocs <- fullAssocsClient aid [CEqp]-  -- We do not consider OFF weapons, because they apparently are not good.-  return $ null $ strongestSlot Effect.EqpSlotWeapon allAssocs-    -- keep it lazy---- | Require that the actor can project any items.-condCanProjectM :: MonadClient m => ActorId -> m Bool-condCanProjectM aid = do-  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid-  benList <- benAvailableItems aid permittedRanged [CEqp, CInv, CGround]-  let missiles = filter (maybe True ((< 0) . snd . snd) . fst . fst) benList-  return $ not actorBlind && not (null missiles)-    -- keep it lazy---- | Produce the list of items with a given property available to the actor--- and the items' values.-benAvailableItems :: MonadClient m-                  => ActorId -> (ItemFull -> Maybe Int -> Bool) -> [CStore]-                  -> m [( (Maybe (Int, (Int, Int)), (Int, CStore))-                        , (ItemId, ItemFull) )]-benAvailableItems aid permitted cstores = do-  cops <- getsState scops-  itemToF <- itemToFullClient-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let ben cstore bag =-        [ ((benefit, (k, cstore)), (iid, itemFull))-        | (iid, k) <- EM.assocs bag-        , let itemFull = itemToF iid k-        , let benefit = totalUsefulness cops b activeItems fact itemFull-        , permitted itemFull (fst <$> benefit)]-      benCStore cs = do-        bag <- getsState $ getActorBag aid cs-        return $! ben cs bag-  perBag <- mapM benCStore cstores-  return $ concat perBag-    -- keep it lazy---- | Require the actor is not calm enough.-condNotCalmEnoughM :: MonadClient m => ActorId -> m Bool-condNotCalmEnoughM aid = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  return $! not (calmEnough b activeItems)---- | Require that the actor stands over a desirable item.-condDesirableFloorItemM :: MonadClient m => ActorId -> m Bool-condDesirableFloorItemM aid = do-  benItemL <- benGroundItems aid-  return $ not $ null benItemL  -- keep it lazy---- | Produce the list of items on the ground beneath the actor.-benGroundItems :: MonadClient m-               => ActorId-               -> m [( (Maybe (Int, (Int, Int))-                     , (Int, CStore)), (ItemId, ItemFull) )]-benGroundItems aid = do-  b <- getsState $ getActorBody aid-  fightsSpawners <- fightsAgainstSpawners (bfid b)-  let desirableItem ItemFull{itemBase} use-        | fightsSpawners = use /= Just 0-                           || Effect.Precious `elem` jfeature itemBase-        | otherwise = use /= Just 0-  benAvailableItems aid desirableItem [CGround]---- | Require the actor is in a bad position to melee.--- We do not check if the actor has a weapon, because having--- no innate weapon is rare.-condMeleeBadM :: MonadClient m => ActorId -> m Bool-condMeleeBadM aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  condNoUsableWeapon <- null <$> pickWeaponClient aid aid-  let friendlyFid fid = fid == bfid b || isAllied fact fid-  friends <- getsState $ actorRegularAssocs friendlyFid (blid b)-  let closeEnough b2 = let dist = chessDist (bpos b) (bpos b2)-                       in dist < 3 && dist > 0-      closeFriends = filter (closeEnough . snd) friends-      strongActor (aid2, b2) = do-        activeItems <- activeItemsClient aid2-        return $! not $ hpTooLow b2 activeItems-  strongCloseFriends <- filterM strongActor closeFriends-  let noFriendlyHelp = length closeFriends < 3 && null strongCloseFriends-  return $ condNoUsableWeapon-           || noFriendlyHelp  -- still not getting friends' help-    -- no $!; keep it lazy---- | Require that the actor stands in the dark, but is betrayed--- by his own equipped light,-condLightBetraysM :: MonadClient m => ActorId -> m Bool-condLightBetraysM aid = do-  b <- getsState $ getActorBody aid-  eqpItems <- map snd <$> fullAssocsClient aid [CEqp]-  let actorEqpShines = sumSlotNoFilter Effect.EqpSlotAddLight eqpItems > 0-  aInAmbient<- getsState $ actorInAmbient b-  return $! not aInAmbient     -- tile is dark, so actor could hide-            && actorEqpShines  -- but actor betrayed by his equipped light---- | Produce a list of acceptable adjacent points to flee to.-fleeList :: MonadClient m => Bool -> ActorId -> m [(Int, Point)]-fleeList panic aid = do-  cops <- getsState scops-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  let tgtPath = case mtgtMPath of  -- prefer fleeing along the path to target-        Just (_, Just (_ : path, _)) -> path-        _ -> []-  b <- getsState $ getActorBody aid-  fact <- getsState $ \s -> sfactionD s EM.! bfid b-  allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)-  lvl@Level{lxsize, lysize} <- getLevel $ blid b-  let posFoes = map bpos allFoes-      accessibleHere = accessible cops lvl $ bpos b-      myVic = vicinity lxsize lysize $ bpos b-      dist p | null posFoes = assert `failure` b-             | otherwise = minimum $ map (chessDist p) posFoes-      dVic = map (dist &&& id) myVic-      -- Flee, if possible. Access required.-      accVic = filter (accessibleHere . snd) $ dVic-      gtVic = filter ((> dist (bpos b)) . fst) accVic-      -- At least don't get closer to enemies, but don't stay adjacent.-      eqVic = filter (\(d, _) -> d == dist (bpos b) && d > 1) accVic-      rewardPath (d, p) =-        if p `elem` tgtPath then Just (9 * d, p)-        else if any (\q -> chessDist p q == 1) tgtPath then Just (d, p)-        else Nothing-      goodVic = mapMaybe rewardPath gtVic-                ++ filter ((`elem` tgtPath) . snd) eqVic-      pathVic = goodVic ++ if panic then accVic \\ goodVic else []-  return pathVic  -- keep it lazy, until other conditions verify danger
− Game/LambdaHack/Client/AI/HandleAbilityClient.hs 
@@ -1,803 +0,0 @@-{-# LANGUAGE DataKinds #-}--- | Semantics of abilities in terms of actions and the AI procedure--- for picking the best action for an actor.-module Game.LambdaHack.Client.AI.HandleAbilityClient-  ( actionStrategy-  ) where--import Control.Applicative-import Control.Arrow (second)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Function-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Ord-import Data.Ratio-import Data.Text (Text)--import Game.LambdaHack.Client.AI.ConditionClient-import Game.LambdaHack.Client.AI.Preferences-import Game.LambdaHack.Client.AI.Strategy-import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind as TileKind--type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility--toAny :: ToAny a-toAny strat = RequestAnyAbility <$> strat---- | AI strategy based on actor's sight, smell, etc.--- Never empty.-actionStrategy :: forall m. MonadClient m-               => ActorId -> m (Strategy RequestAnyAbility)-actionStrategy aid = do-  body <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  condTgtEnemyPresent <- condTgtEnemyPresentM aid-  condTgtEnemyRemembered <- condTgtEnemyRememberedM aid-  condAnyFoeAdj <- condAnyFoeAdjM aid-  threatDistL <- threatDistList aid-  condHpTooLow <- condHpTooLowM aid-  condOnTriggerable <- condOnTriggerableM aid-  condBlocksFriends <- condBlocksFriendsM aid-  condNoEqpWeapon <- condNoEqpWeaponM aid-  condNoUsableWeapon <- null <$> pickWeaponClient aid aid-  condFloorWeapon <- condFloorWeaponM aid-  condCanProject <- condCanProjectM aid-  condNotCalmEnough <- condNotCalmEnoughM aid-  condDesirableFloorItem <- condDesirableFloorItemM aid-  condMeleeBad <- condMeleeBadM aid-  fleeL <- fleeList False aid-  panicFleeL <- fleeList True aid-  let condThreatAdj = not $ null $ takeWhile ((== 1) . fst) threatDistL-      condThreatAtHand = not $ null $ takeWhile ((<= 2) . fst) threatDistL-      condThreatNearby = not $ null $ takeWhile ((<= nearby) . fst) threatDistL-      speed1_5 = speedScale (3%2) (bspeed body activeItems)-      condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > speed1_5)-                          $ takeWhile ((== 1) . fst) threatDistL-      condCanFlee = not (null fleeL || condFastThreatAdj)-  mleader <- getsClient _sleader-  actorSk <- actorSkillsClient aid mleader-  let stratToFreq :: MonadStateRead m-                  => Int -> m (Strategy RequestAnyAbility)-                  -> m (Frequency RequestAnyAbility)-      stratToFreq scale mstrat = do-        st <- mstrat-        return $! scaleFreq scale $ bestVariant st  -- TODO: flatten instead?-      prefix, suffix :: [([Ability], m (Strategy RequestAnyAbility), Bool)]-      prefix =-        [ ( [AbApply], (toAny :: ToAny AbApply)-            <$> applyItem aid ApplyFirstAid-          , condHpTooLow && not condAnyFoeAdj-            && not condOnTriggerable )  -- don't block stairs, perhaps ascend-        , ( [AbTrigger], (toAny :: ToAny AbTrigger)-            <$> trigger aid True-              -- flee via stairs, even if to wrong level-              -- may return via different stairs-          , condOnTriggerable-            && ((condNotCalmEnough || condHpTooLow)-                && condThreatNearby && not condTgtEnemyPresent-                || condMeleeBad && condThreatAdj) )-        , ( [AbMove]-          , flee aid fleeL-          , condMeleeBad && condThreatAdj && condCanFlee )-        , ( [AbDisplace]-          , displaceFoe aid  -- only swap with an enemy to expose him-          , condBlocksFriends && condAnyFoeAdj-            && not condOnTriggerable && not condDesirableFloorItem )-        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)-            <$> pickup aid True-          , condNoEqpWeapon && condFloorWeapon && not condHpTooLow )-        , ( [AbMelee], (toAny :: ToAny AbMelee)-            <$> meleeBlocker aid  -- only melee target or blocker-          , condAnyFoeAdj-            || EM.findWithDefault 0 AbDisplace actorSk <= 0-                 -- melee friends, not displace-               && not (playerLeader $ gplayer fact)  -- not restrained-               && (condTgtEnemyPresent || condTgtEnemyRemembered) )  -- excited-        , ( [AbTrigger], (toAny :: ToAny AbTrigger)-            <$> trigger aid False-          , condOnTriggerable && not condDesirableFloorItem )-        , ( [AbDisplace]  -- prevents some looping movement-          , displaceBlocker aid  -- fires up only when path blocked-          , not condDesirableFloorItem )-        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)-            <$> equipItems aid  -- doesn't take long, very useful if safe-                                -- only if calm enough, so high priority-          , not condAnyFoeAdj && not condDesirableFloorItem ) ]-      distant :: [([Ability], m (Frequency RequestAnyAbility), Bool)]-      distant =-        [ ( [AbProject]  -- for high-value target, shoot even in melee-          , stratToFreq 2 $ (toAny :: ToAny AbProject)-            <$> ranged aid-          , condTgtEnemyPresent && condCanProject && not condOnTriggerable )-        , ( [AbApply]-          , stratToFreq 2 $ (toAny :: ToAny AbApply)-            <$> applyItem aid ApplyAll  -- use any option or scroll-          , (condTgtEnemyPresent || condThreatNearby)  -- can affect enemies-            && not condOnTriggerable )-        , ( [AbMove]-          , stratToFreq (if not condTgtEnemyPresent || condMeleeBad-                         then 1-                         else 100)-            $ chase aid True-          , (condTgtEnemyPresent || condTgtEnemyRemembered)-            && not condDesirableFloorItem-            && not condNoUsableWeapon ) ]-      suffix =-        [ ( [AbMoveItem], (toAny :: ToAny AbMoveItem)-            <$> pickup aid False-          , True )  -- unconditionally, e.g., to give to other party members-        , ( [AbMove]-          , flee aid fleeL-          , condMeleeBad && (condNotCalmEnough && condThreatNearby-                             || condThreatAtHand)-            && condCanFlee )-        , ( [AbMelee], (toAny :: ToAny AbMelee)-            <$> meleeAny aid  -- avoid getting damaged for naught-          , condAnyFoeAdj )-        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)-            <$> unEquipItems aid  -- late, because better to throw than unequip-          , True )-        , ( [AbMove]-            -- TODO: forget old target (e.g., tile), to start shooting,-            -- unless can't shoot, etc.-          , flee aid panicFleeL  -- panic mode; chasing would be pointless-          , condMeleeBad && condThreatNearby && (condNotCalmEnough-                                                 || condThreatAtHand-                                                 || condNoUsableWeapon) )-        , ( [AbMove]-          , chase aid False-          , True )-        , ( [AbWait], (toAny :: ToAny AbWait)-            <$> waitBlockNow-            -- Wait until friends sidestep; ensures strategy is never empty.-            -- TODO: try to switch leader away before that (we already-            -- switch him afterwards)-          , True ) ]-      -- TODO: don't msum not to evaluate until needed-      abInSkill ab = EM.findWithDefault 0 ab actorSk > 0-      checkAction :: ([Ability], m a, Bool) -> Bool-      checkAction (abts, _, cond) = cond && all abInSkill abts-      sumS abAction = do-        let as = filter checkAction abAction-        strats <- sequence $ map (\(_, m, _) -> m) as-        return $! msum strats-      sumF abFreq = do-        let as = filter checkAction abFreq-        strats <- sequence $ map (\(_, m, _) -> m) as-        return $! msum strats-      combineDistant as = fmap liftFrequency $ sumF as-  sumPrefix <- sumS prefix-  comDistant <- combineDistant distant-  sumSuffix <- sumS suffix-  return $! sumPrefix .| comDistant .| sumSuffix---- | A strategy to always just wait.-waitBlockNow :: MonadClient m => m (Strategy (RequestTimed AbWait))-waitBlockNow = return $! returN "wait" ReqWait--pickup :: MonadClient m-       => ActorId -> Bool -> m (Strategy (RequestTimed AbMoveItem))-pickup aid onlyWeapon = do-  benItemL <- benGroundItems aid-  let isWeapon (_, (_, itemFull)) =-        maybe False ((== Effect.EqpSlotWeapon) . fst)-        $ strengthEqpSlot $ itemBase itemFull-      filterWeapon | onlyWeapon = filter isWeapon-                   | otherwise = id-      cmp ((Nothing, _), _) = 5  -- experimenting is fun-      cmp ((Just (n, _), _), _) = abs n-  -- Pick up the best desirable item, if any.-  case reverse $ sortBy (comparing cmp) $ filterWeapon benItemL of-    ((_, (k, _)), (iid, itemFull)) : _ -> do-      updateItemSlot (Just aid) iid-      b <- getsState $ getActorBody aid-      -- TODO: instead of pickup to eqp and then move to inv, pickup to inv-      let toCStore = if goesIntoInv (itemBase itemFull)-                        || eqpOverfull b k-                     then CInv-                     else CEqp-      return $! returN "pickup" $ ReqMoveItem iid k CGround toCStore-    [] -> return reject--equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMoveItem))-equipItems aid = do-  cops@Kind.COps{corule} <- getsState scops-  let RuleKind{rsharedStash} = Kind.stdRuleset corule-  body <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  eqpAssocs <- fullAssocsClient aid [CEqp]-  invAssocs <- fullAssocsClient aid [CInv]-  shaAssocs <- fullAssocsClient aid [CSha]-  condLightBetrays <- condLightBetraysM aid-  let improve :: CStore -> ([(Int, (ItemId, ItemFull))],-                            [(Int, (ItemId, ItemFull))])-              -> Strategy (RequestTimed AbMoveItem)-      improve fromCStore (bestInv, bestEqp) =-        case (bestInv, bestEqp) of-          ((_, (iidInv, _)) : _, []) | not (eqpOverfull body 1) ->-            returN "wield any"-            $ ReqMoveItem iidInv 1 fromCStore CEqp-          ((vInv, (iidInv, _)) : _, (vEqp, _) : _) | not (eqpOverfull body 1)-                                                     && vInv > vEqp ->-            returN "wield better"-            $ ReqMoveItem iidInv 1 fromCStore CEqp-          _ -> reject-      -- We filter out unneeded items. In particular, we ignore them in eqp-      -- when comparing to items we may want to equip. Anyway, the unneeded-      -- items should be removed in yieldUnneeded earlier or soon after.-      filterNeeded (_, itemFull) =-        not $ unneeded cops condLightBetrays body activeItems fact itemFull-      bestThree = bestByEqpSlot (filter filterNeeded invAssocs)-                                (filter filterNeeded eqpAssocs)-                                (filter filterNeeded shaAssocs)-      bEqpInv = msum $ map (improve CInv)-                $ map (\(_, (eqp, inv, _)) -> (inv, eqp)) bestThree-  if nullStrategy bEqpInv-    then if rsharedStash && calmEnough body activeItems-         then return-              $! msum $ map (improve CSha)-              $ map (\(_, (eqp, _, sha)) -> (sha, eqp)) bestThree-         else return reject-    else return bEqpInv--unEquipItems :: MonadClient m-             => ActorId -> m (Strategy (RequestTimed AbMoveItem))-unEquipItems aid = do-  cops@Kind.COps{corule} <- getsState scops-  let RuleKind{rsharedStash} = Kind.stdRuleset corule-  body <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  eqpAssocs <- fullAssocsClient aid [CEqp]-  invAssocs <- fullAssocsClient aid [CInv]-  shaAssocs <- fullAssocsClient aid [CSha]-  condLightBetrays <- condLightBetraysM aid-  let yieldSingleUnneeded (iidEqp, itemEqp) =-        let csha = if rsharedStash && calmEnough body activeItems-                   then CSha-                   else CInv-        in if harmful cops body activeItems fact itemEqp-           then Just $ ReqMoveItem iidEqp (itemK itemEqp) CEqp CInv  -- throw-           else if hinders condLightBetrays body activeItems itemEqp-           then Just $ ReqMoveItem iidEqp (itemK itemEqp) CEqp csha  -- share-           else Nothing-      yieldUnneeded = mapMaybe yieldSingleUnneeded eqpAssocs-      improve :: CStore -> ( Effect.EqpSlot-                           , ( [(Int, (ItemId, ItemFull))]-                             , [(Int, (ItemId, ItemFull))] ) )-              -> Strategy (RequestTimed AbMoveItem)-      improve fromCStore (slot, (bestInv, bestEqp)) =-        case (bestInv, bestEqp) of-          _ | slot == Effect.EqpSlotPeriodic-              && fromCStore == CEqp-              && not (eqpOverfull body 0) ->-            -- Don't get rid of periodic items from eqp unless eqp full.-            reject-          (_, (vEqp, (iidEqp, _)) : _) | getK bestEqp > 1-                                         && betterThanInv vEqp bestInv ->-            -- To share the best items with others, if they care.-            returN "yield rest"-            $ ReqMoveItem iidEqp (getK bestEqp - 1) fromCStore CSha-          (_, _ : (vEqp, (iidEqp, _)) : _) | betterThanInv vEqp bestInv ->-            -- To share the second best items with others, if they care.-            returN "yield worse"-            $ ReqMoveItem iidEqp (getK bestEqp) fromCStore CSha-          _ -> reject-      getK [] = 0-      getK ((_, (_, itemFull)) : _) = itemK itemFull-      betterThanInv _ [] = True-      betterThanInv vEqp ((vInv, _) : _) = vEqp > vInv-      bestThree = bestByEqpSlot invAssocs eqpAssocs shaAssocs-  case yieldUnneeded of-    [] ->-      if rsharedStash && calmEnough body activeItems-      then do-        let bInvSha = msum $ map (improve CInv)-                      $ map (\((slot, _), (_, inv, sha)) ->-                               (slot, (sha, inv))) bestThree-        if nullStrategy bInvSha-          then return $! msum $ map (improve CEqp)-                         $ map (\((slot, _), (eqp, _, sha)) ->-                                 (slot, (sha, eqp))) bestThree-          else return $! bInvSha-        else return reject-    _ ->-      -- Here AI hides from the human player the Ring of Speed And Bleeding,-      -- which is a bit harsh, but fair. However any subsequent such-      -- rings will not be picked up at all, so the human player-      -- doesn't lose much fun. Additionally, if AI learns alchemy later on,-      -- they can repair the ring, wield it, drop at death and it's-      -- in play again.-      return $! liftFrequency $ uniformFreq "yield unneeded" yieldUnneeded--groupByEqpSlot :: [(ItemId, ItemFull)]-               -> M.Map (Effect.EqpSlot, Text) [(ItemId, ItemFull)]-groupByEqpSlot is =-  let f (iid, itemFull) = case strengthEqpSlot $ itemBase itemFull of-        Nothing -> Nothing-        Just es -> Just (es, [(iid, itemFull)])-      withES = mapMaybe f is-  in M.fromListWith (++) withES--bestByEqpSlot :: [(ItemId, ItemFull)]-              -> [(ItemId, ItemFull)]-              -> [(ItemId, ItemFull)]-              -> [((Effect.EqpSlot, Text)-                  , ( [(Int, (ItemId, ItemFull))]-                    , [(Int, (ItemId, ItemFull))]-                    , [(Int, (ItemId, ItemFull))] ) )]-bestByEqpSlot invAssocs eqpAssocs shaAssocs =-  let eqpMap = M.map (\g -> (g, [], [])) $ groupByEqpSlot eqpAssocs-      invMap = M.map (\g -> ([], g, [])) $ groupByEqpSlot invAssocs-      shaMap = M.map (\g -> ([], [], g)) $ groupByEqpSlot shaAssocs-      appendThree (g1, g2, g3) (h1, h2, h3) = (g1 ++ h1, g2 ++ h2, g3 ++ h3)-      invEqpShaMap = M.unionsWith appendThree [invMap, eqpMap, shaMap]-      bestSingle eqpSlot g = strongestSlot eqpSlot g-      bestThree (eqpSlot, _) (g1, g2, g3) = (bestSingle eqpSlot g1,-                                             bestSingle eqpSlot g2,-                                             bestSingle eqpSlot g3)-  in M.assocs $ M.mapWithKey bestThree invEqpShaMap--hinders :: Bool -> Actor -> [ItemFull] -> ItemFull -> Bool-hinders condLightBetrays body activeItems itemFull =-  -- Fast actors want to hide in darkness to ambush opponents and want-  -- to hit hard for the short span they get to survive melee.-  (bspeed body activeItems > speedNormal-   && (isJust (strengthFromEqpSlot Effect.EqpSlotAddLight itemFull)-       || 0 > fromMaybe 0 (strengthFromEqpSlot Effect.EqpSlotAddHurtMelee-                                               itemFull)-       || 0 > fromMaybe 0 (strengthFromEqpSlot Effect.EqpSlotAddHurtRanged-                                               itemFull)))-  -- Distressed actors want to hide in the dark.-  || (let heavilyDistressed =  -- actor hit by a proj or similarly distressed-            deltaSerious (bcalmDelta body)-      in condLightBetrays && heavilyDistressed-         && isJust (strengthFromEqpSlot Effect.EqpSlotAddLight itemFull))-  -- TODO:-  -- teach AI to turn shields OFF (or stash) when ganging up on an enemy-  -- (friends close, only one enemy close)-  -- and turning on afterwards (AI plays for time, especially spawners-  -- so shields are preferable by default;-  -- also, turning on when no friends and enemies close is too late,-  -- AI should flee or fire at such times, not muck around with eqp)--harmful :: Kind.COps -> Actor -> [ItemFull] -> Faction -> ItemFull -> Bool-harmful cops body activeItems fact itemFull =-  -- items that are known and their effects are not stricly beneficial-  -- should not be equipped (either they are harmful or they waste eqp space).-  maybe False (\(u, _) -> u <= 0)-    (totalUsefulness cops body activeItems fact itemFull)-  && (maybe True ((/= Effect.EqpSlotWeapon) . fst)-      $ strengthEqpSlot $ itemBase itemFull)--unneeded :: Kind.COps -> Bool -> Actor -> [ItemFull] -> Faction -> ItemFull-         -> Bool-unneeded cops condLightBetrays body activeItems fact itemFull =-  harmful cops body activeItems fact itemFull-  || hinders condLightBetrays body activeItems itemFull---- Everybody melees in a pinch, even though some prefer ranged attacks.-meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))-meleeBlocker aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  mleader <- getsClient _sleader-  actorSk <- actorSkillsClient aid mleader-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  case mtgtMPath of-    Just (_, Just (_ : q : _, (goal, _))) -> do-      -- We prefer the goal (e.g., when no accessible, but adjacent),-      -- but accept @q@ even if it's only a blocking enemy position.-      let maim = if adjacent (bpos b) goal then Just goal-                 else if adjacent (bpos b) q then Just q-                 else Nothing  -- MeleeDistant-      mBlocker <- case maim of-        Nothing -> return Nothing-        Just aim -> getsState $ posToActor aim (blid b)-      case mBlocker of-        Just ((aid2, _), _) -> do-          -- No problem if there are many projectiles at the spot. We just-          -- attack the first one.-          body2 <- getsState $ getActorBody aid2-          if not (actorDying body2)  -- already dying-             && (not (bproj body2)  -- displacing saves a move-                 && isAtWar fact (bfid body2)  -- they at war with us-                 || EM.findWithDefault 0 AbDisplace actorSk <= 0  -- not disp.-                    && not (playerLeader $ gplayer fact)  -- not restrained-                    && EM.findWithDefault 0 AbMove actorSk > 0  -- blocked move-                    && bhp body2 < bhp b)  -- respect power-            then do-              mel <- pickWeaponClient aid aid2-              return $! liftFrequency $ uniformFreq "melee in the way" mel-            else return reject-        Nothing -> return reject-    _ -> return reject  -- probably no path to the enemy, if any---- Everybody melees in a pinch, skills and weapons allowing,--- even though some prefer ranged attacks.-meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))-meleeAny aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  let adjFoes = filter (adjacent (bpos b) . bpos . snd) allFoes-  mels <- mapM (pickWeaponClient aid . fst) adjFoes-      -- TODO: prioritize somehow-  let freq = uniformFreq "melee adjacent" $ concat mels-  return $! liftFrequency freq---- Fast monsters don't pay enough attention to features.-trigger :: MonadClient m-        => ActorId -> Bool -> m (Strategy (RequestTimed AbTrigger))-trigger aid fleeViaStairs = do-  cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  lvl <- getLevel $ blid b-  unexploredD <- unexploredDepth-  s <- getState-  per <- getPerFid $ blid b-  let canSee = ES.member (bpos b) (totalVisible per)-      unexploredCurrent = ES.notMember (blid b) explored-      allExplored = ES.size explored == EM.size dungeon-      t = lvl `at` bpos b-      feats = TileKind.tfeature $ okind t-      ben feat = case feat of-        F.Cause (Effect.Ascend k) ->  -- change levels sensibly, in teams-          let expBenefit =-                if not (playerLeader (gplayer fact))-                then 100  -- not-exploring faction, switch at will-                else if unexploredCurrent-                then 0  -- don't leave the level until explored-                else if unexploredD (signum k) (blid b)-                then 1000-                else if unexploredD (- signum k) (blid b)-                then 0  -- wait for stairs in the opposite direciton-                else if lescape lvl-                then 0  -- all explored, stay on the escape level-                else 2  -- no escape anywhere, switch levels occasionally-              (lid2, pos2) = whereTo (blid b) (bpos b) k dungeon-              actorsThere = posToActors pos2 lid2 s-              leaderless = not $ playerLeader $ gplayer fact-          in if boldpos b == bpos b   -- probably used stairs last turn-                && boldlid b == lid2  -- in the opposite direction-             then 0  -- avoid trivial loops (pushing, being pushed, etc.)-             else let eben = case actorsThere of-                        [] | canSee -> expBenefit-                        _ | leaderless -> 0  -- leaderless clog stairs easily-                        _ -> min 1 expBenefit  -- risk pushing-                  in if fleeViaStairs-                     then 1000 * eben + 1  -- strongly prefer correct direction-                     else eben-        F.Cause ef@Effect.Escape{} -> do  -- flee via this way, too-          -- Only some factions try to escape but they first explore all-          -- for high score.-          if not (keepArenaFact fact) || not allExplored-          then 0-          else effectToBenefit cops b activeItems fact ef-        F.Cause ef | not fleeViaStairs ->-          effectToBenefit cops b activeItems fact ef-        _ -> 0-      benFeat = zip (map ben feats) feats-  return $! liftFrequency $ toFreq "trigger"-         $ [ (benefit, ReqTrigger (Just feat))-           | (benefit, feat) <- benFeat-           , benefit > 0 ]--ranged :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbProject))-ranged aid = do-  btarget <- getsClient $ getTarget aid-  b@Actor{bpos, blid} <- getsState $ getActorBody aid-  mfpos <- aidTgtToPos aid blid btarget-  seps <- getsClient seps-  case (btarget, mfpos) of-    (Just TEnemy{}, Just fpos) -> do-      actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid-      mnewEps <- makeLine b fpos seps-      case mnewEps of-        Just newEps | not actorBlind -> do  -- ProjectBlind-          -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain-          -- and no actors or obstracles along the path.-          benList <- benAvailableItems aid permittedRanged [CEqp, CInv, CGround]-          let coeff CGround = 2-              coeff COrgan = 3  -- can't give to others-              coeff CEqp = 1-              coeff CInv = 1-              coeff CSha = undefined  -- banned-              fRanged ((mben, (_, cstore)), (iid, ItemFull{itemBase})) =-                let trange = totalRange itemBase-                    bestRange = chessDist bpos fpos + 2  -- margin for fleeing-                    rangeMult =  -- penalize wasted or unsafely low range-                      10 + max 0 (10 - abs (trange - bestRange))-                    durableBonus = if Effect.Durable `elem` jfeature itemBase-                                   then 2  -- we or foes keep it after the throw-                                   else 1-                    benR = durableBonus-                           * coeff cstore-                           * case mben of-                               Nothing -> -20  -- experimenting is fun-                               Just (_, (_, ben)) -> ben-                in if benR < 0 && trange >= chessDist bpos fpos-                   then Just ( -benR * rangeMult `div` 10-                             , ReqProject fpos newEps iid cstore )-                   else Nothing-              benRanged = mapMaybe fRanged benList-          return $! liftFrequency $ toFreq "ranged" benRanged-        _ -> return reject-    _ -> return reject--data ApplyItemGroup = ApplyAll | ApplyFirstAid-  deriving Eq--applyItem :: MonadClient m-          => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed AbApply))-applyItem aid applyGroup = do-  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid-  let permitted itemFull@ItemFull{itemBase=item} _ =-        not (unknownPrecious itemFull)-        && if jsymbol item == '?' && actorBlind-           then False-           else Effect.Applicable `elem` jfeature item-  benList <- benAvailableItems aid permitted [CEqp, CInv, CGround]-  let itemLegal itemFull = case applyGroup of-        ApplyFirstAid ->-          let getP (Effect.RefillHP p) _ | p > 0 = True-              getP _ acc = acc-          in case itemDisco itemFull of-            Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-              foldr getP False jeffects-            _ -> False-        ApplyAll -> True-      coeff CGround = 2-      coeff COrgan = 3  -- can't give to others-      coeff CEqp = 1-      coeff CInv = 1-      coeff CSha = undefined  -- banned-      fTool ((mben, (_, cstore)), (iid, itemFull)) =-        let durableBonus = if Effect.Durable `elem` jfeature (itemBase itemFull)-                           then 5  -- we keep it after use-                           else 1-            benR = durableBonus-                   * coeff cstore-                   * case mben of-                       Nothing -> 0-                         -- experimenting is fun, but it's better to risk-                         -- foes' skin than ours -- TODO: when {activated}-                         -- is implemented, enable this for items too heavy,-                         -- etc. for throwing-                       Just (_, (_, ben)) -> ben-        in if itemLegal itemFull-           then if benR > 0-                then Just (benR, ReqApply iid cstore)-                else Nothing-           else Nothing-      benTool = mapMaybe fTool benList-  return $! liftFrequency $ toFreq "applyItem" benTool---- If low on health or alone, flee in panic, close to the path to target--- and as far from the attackers, as possible. Usually fleeing from--- foes will lead towards friends, but we don't insist on that.--- We use chess distances, not pathfinding, because melee can happen--- at path distance 2.-flee :: MonadClient m-     => ActorId -> [(Int, Point)] -> m (Strategy RequestAnyAbility)-flee aid fleeL = do-  b <- getsState $ getActorBody aid-  let vVic = map (second (`vectorToFrom` bpos b)) fleeL-      str = liftFrequency $ toFreq "flee" vVic-  mapStrategyM (moveOrRunAid True aid) str--displaceFoe :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)-displaceFoe aid = do-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  lvl <- getLevel $ blid b-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let friendlyFid fid = fid == bfid b || isAllied fact fid-  friends <- getsState $ actorRegularList friendlyFid (blid b)-  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  let accessibleHere = accessible cops lvl $ bpos b  -- DisplaceAccess-      displaceable body =  -- DisplaceAccess, DisplaceDying, DisplaceSupported-        accessibleHere (bpos body)-        && adjacent (bpos body) (bpos b)-      nFriends body = length $ filter (adjacent (bpos body) . bpos) friends-      nFrHere = nFriends b + 1-      qualifyActor (aid2, body2) = do-        activeItems <- activeItemsClient aid2-        dEnemy <- getsState $ dispEnemy aid aid2 activeItems-        let nFr = nFriends body2-        return $! if displaceable body2 && dEnemy && nFr < nFrHere-          then Just (nFr * nFr, bpos body2 `vectorToFrom` bpos b)-          else Nothing-  vFoes <- mapM qualifyActor allFoes-  let str = liftFrequency $ toFreq "displaceFoe" $ catMaybes vFoes-  mapStrategyM (moveOrRunAid True aid) str--displaceBlocker :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)-displaceBlocker aid = do-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  str <- case mtgtMPath of-    Just (_, Just (p : q : _, _)) -> displaceTowards aid p q-    _ -> return reject  -- goal reached-  mapStrategyM (moveOrRunAid True aid) str---- TODO: perhaps modify target when actually moving, not when--- producing the strategy, even if it's a unique choice in this case.-displaceTowards :: MonadClient m-                => ActorId -> Point -> Point -> m (Strategy Vector)-displaceTowards aid source target = do-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  assert (source == bpos b && adjacent source target) skip-  lvl <- getLevel $ blid b-  if boldpos b /= target -- avoid trivial loops-     && accessible cops lvl source target then do  -- DisplaceAccess-    mBlocker <- getsState $ posToActors target (blid b)-    case mBlocker of-      [] -> return reject-      [((aid2, b2), _)] -> do-        mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD-        case mtgtMPath of-          Just (tgt, Just (p : q : rest, (goal, len)))-            | q == source && p == target -> do-              let newTgt = Just (tgt, Just (q : rest, (goal, len - 1)))-              modifyClient $ \cli ->-                cli {stargetD = EM.alter (const $ newTgt) aid (stargetD cli)}-              return $! returN "displace friend" $ target `vectorToFrom` source-          Just _ -> return reject-          Nothing -> do-            tfact <- getsState $ (EM.! bfid b2) . sfactionD-            activeItems <- activeItemsClient aid2-            dEnemy <- getsState $ dispEnemy aid aid2 activeItems-            if not (isAtWar tfact (bfid b)) || dEnemy then-              return $! returN "displace other" $ target `vectorToFrom` source-            else return reject  -- DisplaceDying, DisplaceSupported-      _ -> return reject  -- DisplaceProjectiles-  else return reject--chase :: MonadClient m => ActorId -> Bool -> m (Strategy RequestAnyAbility)-chase aid doDisplace = do-  body <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  str <- case mtgtMPath of-    Just (_, Just (p : q : _, (goal, _))) ->-      -- With no leader, the goal is vague, so permit arbitrary detours.-      moveTowards aid p q goal (not $ playerLeader (gplayer fact))-    _ -> return reject  -- goal reached-  -- If @doDisplace@: don't pick fights, assuming the target is more important.-  -- We'd normally melee the target earlier on via @AbMelee@, but for-  -- actors that don't have this ability (and so melee only when forced to),-  -- this is meaningul.-  mapStrategyM (moveOrRunAid doDisplace aid) str--moveTowards :: MonadClient m-            => ActorId -> Point -> Point -> Point -> Bool -> m (Strategy Vector)-moveTowards aid source target goal relaxed = do-  cops@Kind.COps{cotile} <- getsState scops-  b <- getsState $ getActorBody aid-  assert (source == bpos b && adjacent source target) skip-  lvl <- getLevel $ blid b-  fact <- getsState $ (EM.! bfid b) . sfactionD-  friends <- getsState $ actorList (not . isAtWar fact) $ blid b-  let noFriends = unoccupied friends-      accessibleHere = accessible cops lvl source-      bumpableHere p =-        let t = lvl `at` p-        in Tile.isOpenable cotile t-           || Tile.isSuspect cotile t-           || Tile.isChangeable cotile t-      enterableHere p = accessibleHere p || bumpableHere p-  if noFriends target && enterableHere target then-    return $! returN "moveTowards adjacent" $ target `vectorToFrom` source-  else do-    let goesBack v = v == boldpos b `vectorToFrom` source-        nonincreasing p = chessDist source goal >= chessDist p goal-        isSensible p = (relaxed || nonincreasing p)-                       && noFriends p-                       && enterableHere p-        sensible = [ ((goesBack v, chessDist p goal), v)-                   | v <- moves, let p = source `shift` v, isSensible p ]-        sorted = sortBy (comparing fst) sensible-        groups = map (map snd) $ groupBy ((==) `on` fst) sorted-        freqs = map (liftFrequency . uniformFreq "moveTowards") groups-    return $! foldr (.|) reject freqs---- | Actor moves or searches or alters or attacks. Displaces if @run@.--- This function is very general, even though it's often used in contexts--- when only one or two of the many cases can possibly occur.-moveOrRunAid :: MonadClient m-             => Bool -> ActorId -> Vector -> m (Maybe RequestAnyAbility)-moveOrRunAid run source dir = do-  cops@Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-  lvl <- getLevel lid-  let spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-      t = lvl `at` tpos-  -- We start by checking actors at the the target position,-  -- which gives a partial information (actors can be invisible),-  -- as opposed to accessibility (and items) which are always accurate-  -- (tiles can't be invisible).-  tgts <- getsState $ posToActors tpos lid-  case tgts of-    [((target, b2), _)] | run ->  do -- can be a foe, as well as a friend-      tfact <- getsState $ (EM.! bfid b2) . sfactionD-      activeItems <- activeItemsClient target-      dEnemy <- getsState $ dispEnemy source target activeItems-      if boldpos sb /= tpos -- avoid trivial Displace loops-         && accessible cops lvl spos tpos -- DisplaceAccess-         && (not (isAtWar tfact (bfid sb))-             || dEnemy)  -- DisplaceDying, DisplaceSupported-      then-        return $! Just $ RequestAnyAbility $ ReqDisplace target-      else do-        -- If cannot displace, hit. TODO: unless melee or wait not permitted.-        wps <- pickWeaponClient source target-        case wps of-          [] -> return Nothing-          wp : _ -> return $! Just $ RequestAnyAbility wp-    ((target, _), _) : _ -> do  -- can be a foe, as well as friend (e.g., proj.)-      -- No problem if there are many projectiles at the spot. We just-      -- attack the first one.-      -- Attacking does not require full access, adjacency is enough.-      wps <- pickWeaponClient source target-      case wps of-        [] -> return Nothing-        wp : _ -> return $! Just $ RequestAnyAbility wp-    [] -> do  -- move or search or alter-      if accessible cops lvl spos tpos then-        -- Movement requires full access.-        return $! Just $ RequestAnyAbility $ ReqMove dir-        -- The potential invisible actor is hit.-      else if not $ EM.null $ lvl `atI` tpos then-        -- This is, e.g., inaccessible open door with an item in it.-        assert `failure` "AI causes AlterBlockItem" `twith` (run, source, dir)-      else if not (Tile.isWalkable cotile t)  -- not implied-              && (Tile.isSuspect cotile t-                  || Tile.isOpenable cotile t-                  || Tile.isClosable cotile t-                  || Tile.isChangeable cotile t) then-        -- No access, so search and/or alter the tile.-        return $! Just $ RequestAnyAbility $ ReqAlter tpos Nothing-      else-        -- Boring tile, no point bumping into it, do WaitSer if really idle.-        assert `failure` "AI causes MoveNothing or AlterNothing"-               `twith` (run, source, dir)
− Game/LambdaHack/Client/AI/PickActorClient.hs 
@@ -1,197 +0,0 @@--- | Semantics of most 'ResponseAI' client commands.-module Game.LambdaHack.Client.AI.PickActorClient-  ( pickActorToMove-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import Data.Ord--import Game.LambdaHack.Client.AI.ConditionClient-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector--pickActorToMove :: MonadClient m-                => (ActorId -> (ActorId, Actor)-                    -> m (Maybe ((ActorId, Actor), (Target, PathEtc))))-                -> ActorId-                -> m (ActorId, Actor)-pickActorToMove refreshTarget oldAid = do-  cops@Kind.COps{cotile} <- getsState scops-  oldBody <- getsState $ getActorBody oldAid-  let side = bfid oldBody-      arena = blid oldBody-  fact <- getsState $ (EM.! side) . sfactionD-  lvl <- getLevel arena-  let leaderStuck = waitedLastTurn oldBody-      t = lvl `at` bpos oldBody-  mleader <- getsClient _sleader-  ours <- getsState $ actorRegularAssocs (== side) arena-  let pickOld = do-        void $ refreshTarget oldAid (oldAid, oldBody)-        return (oldAid, oldBody)-  case ours of-    _ | -- Keep the leader: only a leader is allowed to pick another leader.-        mleader /= Just oldAid-        -- Keep the leader: all can move. TODO: check not accurate,-        -- instead define 'movesThisTurn' and use elsehwere.-        || isAllMoveFact cops fact-        -- Keep the leader: he is on stairs and not stuck-        -- and we don't want to clog stairs or get pushed to another level.-        || not leaderStuck && Tile.isStair cotile t-      -> pickOld-    [] -> assert `failure` (oldAid, oldBody)-    [_] -> pickOld  -- Keep the leader: he is alone on the level.-    (captain, captainBody) : (sergeant, sergeantBody) : _ -> do-      -- At this point we almost forget who the old leader was-      -- and treat all party actors the same, eliminating candidates-      -- until we can't distinguish them any more, at which point we prefer-      -- the old leader, if he is among the best candidates-      -- (to make the AI appear more human-like and easier to observe).-      -- TODO: this also takes melee into account, but not shooting.-      oursTgt <- fmap catMaybes $ mapM (refreshTarget oldAid) ours-      let actorWeak ((aid, body), _) = do-            activeItems <- activeItemsClient aid-            condMeleeBad <- condMeleeBadM aid-            threatDistL <- threatDistList aid-            fleeL <- fleeList False aid-            let condThreatAdj =-                  not $ null $ takeWhile ((== 1) . fst) threatDistL-                condFastThreatAdj =-                  any (\(_, (_, b)) ->-                         bspeed b activeItems > bspeed body activeItems)-                  $ takeWhile ((== 1) . fst) threatDistL-                condCanFlee = not (null fleeL || condFastThreatAdj)-                heavilyDistressed =-                  -- Actor hit by a projectile or similarly distressed.-                  deltaSerious (bcalmDelta body)-            return $! if condThreatAdj-                      then condMeleeBad && condCanFlee-                      else heavilyDistressed-                        -- TODO: modify when reaction fire is possible-          actorHearning (_, (TEnemyPos{}, (_, (_, d)))) | d <= 2 =-            return False  -- noise probably due to fleeing target-          actorHearning ((_aid, b), _) = do-            allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)-            let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes-                mildlyDistressed = deltaMild (bcalmDelta b)-            return $! mildlyDistressed  -- e.g., actor hears an enemy-                      && null closeFoes  -- the enemy not visible; a trap!-          -- AI has to be prudent and not lightly waste leader for meleeing,-          -- even if his target is distant-          actorMeleeing ((aid, _), _) = condAnyFoeAdjM aid-      oursWeak <- filterM actorWeak oursTgt-      oursStrong <- filterM (fmap not . actorWeak) oursTgt  -- TODO: partitionM-      oursMeleeing <- filterM actorMeleeing oursStrong-      oursNotMeleeing <- filterM (fmap not . actorMeleeing) oursStrong-      oursHearing <- filterM actorHearning oursNotMeleeing-      oursNotHearing <- filterM (fmap not . actorHearning) oursNotMeleeing-      let targetTEnemy (_, (TEnemy{}, _)) = True-          targetTEnemy (_, (TEnemyPos{}, _)) = True-          targetTEnemy _ = False-          (oursTEnemy, oursOther) = partition targetTEnemy oursNotHearing-          -- These are not necessarily stuck (perhaps can go around),-          -- but their current path is blocked by friends.-          targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) =-            let next = case path of-                  [] -> assert `failure` our-                  [_goal] -> Nothing-                  _ : q : _ -> Just q-            in any ((== next) . Just . bpos . snd) ours--- TODO: stuck actors are picked while others close could approach an enemy;--- we should detect stuck actors (or one-sided stuck)--- so far we only detect blocked and only in Other mode---             && not (aid == oldAid && waitedLastTurn b time)  -- not stuck--- this only prevents staying stuck-          (oursBlocked, oursPos) = partition targetBlocked oursOther-          -- Lower overhead is better.-          overheadOurs :: ((ActorId, Actor), (Target, PathEtc))-                       -> (Int, Int, Bool)-          overheadOurs our@((aid, b), (_, (_, (goal, d)))) =-            if targetTEnemy our then-              -- TODO: take weapon, walk and fight speed, etc. into account-              ( d + if targetBlocked our then 2 else 0  -- possible delay, hacky-              , - 10 * (fromIntegral $ bhp b `div` (10 * oneM))-              , aid /= oldAid )-            else-              -- Keep proper formation, not too dense, not to sparse.-              let-                -- TODO: vary the parameters according to the stage of game,-                -- enough equipment or not, game mode, level map, etc.-                minSpread = 7-                maxSpread = 12 * 2-                dcaptain p =-                  chessDistVector $ bpos captainBody `vectorToFrom` p-                dsergeant p =-                  chessDistVector $ bpos sergeantBody `vectorToFrom` p-                minDist | aid == captain = dsergeant (bpos b)-                        | aid == sergeant = dcaptain (bpos b)-                        | otherwise = dsergeant (bpos b)-                                      `min` dcaptain (bpos b)-                pDist p = dcaptain p + dsergeant p-                sumDist = pDist (bpos b)-                -- Positive, if the goal gets us closer to the party.-                diffDist = sumDist - pDist goal-                minCoeff | minDist < minSpread =-                  (minDist - minSpread) `div` 3-                  - if aid == oldAid then 3 else 0-                         | otherwise = 0-                explorationValue = diffDist * (sumDist `div` 4)--- TODO: this half is not yet ready:--- instead spread targets between actors; moving many actors--- to a single target and stopping and starting them--- is very wasteful; also, pick targets not closest to the actor in hand,--- but to the sum of captain and sergant or something-                sumCoeff | sumDist > maxSpread = - explorationValue-                         | otherwise = 0-              in ( if d == 0 then d-                   else max 1 $ minCoeff + if d < 10-                                           then 3 + d `div` 4-                                           else 9 + d `div` 10-                 , sumCoeff-                 , aid /= oldAid )-          sortOurs = sortBy $ comparing overheadOurs-          goodGeneric ((aid, b), (_tgt, _pathEtc)) =-            not (aid == oldAid && waitedLastTurn b)  -- not stuck-          goodTEnemy our@((_aid, b), (TEnemy{}, (_path, (goal, _d)))) =-            not (adjacent (bpos b) goal) -- not in melee range already-            && goodGeneric our-          goodTEnemy our = goodGeneric our-          oursWeakGood = filter goodTEnemy oursWeak-          oursTEnemyGood = filter goodTEnemy oursTEnemy-          oursPosGood = filter goodGeneric oursPos-          oursMeleeingGood = filter goodGeneric oursMeleeing-          oursHearingGood = filter goodTEnemy oursHearing-          oursBlockedGood = filter goodGeneric oursBlocked-          candidates = [ sortOurs oursWeakGood-                       , sortOurs oursTEnemyGood-                       , sortOurs oursPosGood-                       , sortOurs oursMeleeingGood-                       , sortOurs oursHearingGood-                       , sortOurs oursBlockedGood-                       ]-      case filter (not . null) candidates of-        l@(c : _) : _ -> do-          let best = takeWhile ((== overheadOurs c) . overheadOurs) l-              freq = uniformFreq "candidates for AI leader" best-          ((aid, b), _) <- rndToAction $ frequency freq-          s <- getState-          modifyClient $ updateLeader aid s-          return (aid, b)-        _ -> return (oldAid, oldBody)
− Game/LambdaHack/Client/AI/PickTargetClient.hs 
@@ -1,310 +0,0 @@--- | Let AI pick the best target for an actor.-module Game.LambdaHack.Client.AI.PickTargetClient-  ( targetStrategy-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Maybe--import Game.LambdaHack.Client.AI.ConditionClient-import Game.LambdaHack.Client.AI.Preferences-import Game.LambdaHack.Client.AI.Strategy-import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ModeKind---- | AI proposes possible targets for the actor. Never empty.-targetStrategy :: forall m. MonadClient m-               => ActorId -> ActorId -> m (Strategy (Target, Maybe PathEtc))-targetStrategy oldLeader aid = do-  cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops-  itemToF <- itemToFullClient-  modifyClient $ \cli -> cli { sbfsD = EM.delete aid (sbfsD cli)-                             , seps = seps cli + 773 }  -- randomize paths-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsClient aid-  lvl@Level{lxsize, lysize} <- getLevel $ blid b-  let stepAccesible mtgt@(Just (_, (p : q : _ : _, _))) = -- goal not adjacent-        if accessible cops lvl p q then mtgt else Nothing-      stepAccesible mtgt = mtgt  -- goal can be inaccessible, e.g., suspect-      createPath :: Target -> m (Maybe (Target, PathEtc))-      createPath tgt = do-        mpos <- aidTgtToPos aid (blid b) (Just tgt)-        case mpos of-          Nothing -> return Nothing-          Just p -> do-            (bfs, mpath) <- getCacheBfsAndPath aid p-            return $! case mpath of-              Nothing -> Nothing-              Just path -> Just (tgt, ( bpos b : path-                                      , (p, fromMaybe (assert `failure` mpath)-                                            $ accessBfs bfs p) ))-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  oldTgtUpdatedPath <- case mtgtMPath of-    Just (tgt, Just path) -> do-      mvalidPos <- aidTgtToPos aid (blid b) (Just tgt)-      if isNothing mvalidPos then return Nothing  -- wrong level-      else return $! case path of-        (p : q : rest, (goal, len)) -> stepAccesible $-          if bpos b == p-          then Just (tgt, path)  -- no move last turn-          else if bpos b == q-               then Just (tgt, (q : rest, (goal, len - 1)))  -- step along path-               else Nothing  -- veered off the path-        ([p], (goal, _)) -> do-          assert (p == goal `blame` (aid, b, mtgtMPath)) skip-          if bpos b == p then-            Just (tgt, path)  -- goal reached; stay there picking up items-          else-            Nothing  -- somebody pushed us off the goal; let's target again-        ([], _) -> assert `failure` (aid, b, mtgtMPath)-    Just (tgt@TEnemyPos{}, Nothing) ->-      -- special case, TEnemyPos would be lost otherwise-      createPath tgt-    Just (_, Nothing) -> return Nothing  -- path invalidated, e.g. UpdSpotActor-    Nothing -> return Nothing  -- no target assigned yet-  assert (not $ bproj b) skip  -- would work, but is probably a bug-  fact <- getsState $ (EM.! bfid b) . sfactionD-  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  dungeon <- getsState sdungeon-  itemD <- getsState sitemD-  -- TODO: we assume the actor eventually becomes a leader (or has the same-  -- set of abilities as the leader, anyway) and set his target accordingly.-  actorSk <- actorSkillsClient aid (Just aid)-  condCanProject <- condCanProjectM aid-  condMeleeBad <- condMeleeBadM aid-  condHpTooLow <- condHpTooLowM aid-  let friendlyFid fid = fid == bfid b || isAllied fact fid-  friends <- getsState $ actorRegularList friendlyFid (blid b)-  -- TODO: refine all this when some actors specialize in ranged attacks-  -- (then we have to target, but keep the distance, we can do similarly for-  -- wounded or alone actors, perhaps only until they are shot first time,-  -- and only if they can shoot at the moment)-  fightsSpawners <- fightsAgainstSpawners (bfid b)-  explored <- getsClient sexplored-  smellRadius <- sumOrganEqpClient Effect.EqpSlotAddSmell aid-  let canSmell = smellRadius > 0-      meleeNearby | fightsSpawners = nearby `div` 2  -- not aggresive-                  | otherwise = nearby-      rangedNearby = 2 * meleeNearby-      targetableMelee body =-        chessDist (bpos body) (bpos b) < meleeNearby-        && not condMeleeBad-      targetableRangedOrSpecial body =-        chessDist (bpos body) (bpos b) < rangedNearby-        && (condCanProject-            || hpTooLow body activeItems  -- easy prey-            || any (adjacent (bpos body) . bpos) friends)  -- attacks friends!-      targetableEnemy body =-        targetableMelee body || targetableRangedOrSpecial body-      nearbyFoes = filter (targetableEnemy . snd) allFoes-      unknownId = ouniqGroup "unknown space"-      itemUsefulness iid k =-        case totalUsefulness cops b activeItems fact (itemToF iid k) of-          Just (v, _) -> v-          Nothing -> 30  -- experimenting is fun-      desirableItem iid item k-        | fightsSpawners = itemUsefulness iid k /= 0-                           || Effect.Precious `elem` jfeature item-        | otherwise = itemUsefulness iid k /= 0-      desirableBag bag = any (\(iid, k) ->-                               desirableItem iid (itemD EM.! iid) k)-                         $ EM.assocs bag-      desirable (_, (_, Nothing)) = True-      desirable (_, (_, Just bag)) = desirableBag bag-      -- TODO: make more common when weak ranged foes preferred, etc.-      focused = bspeed b activeItems < speedNormal || condHpTooLow-      setPath :: Target -> m (Strategy (Target, Maybe PathEtc))-      setPath tgt = do-        mpath <- createPath tgt-        return $! returN "pickNewTarget"-               $ maybe (tgt, Nothing) (\(t, p) -> (t, Just p)) mpath-      pickNewTarget :: m (Strategy (Target, Maybe PathEtc))-      pickNewTarget = do-        -- TODO: for foes, items, etc. consider a few nearby, not just one-        cfoes <- closestFoes nearbyFoes aid-        case cfoes of-          (_, (aid2, _)) : _ -> setPath $ TEnemy aid2 False-          [] -> do-            -- Tracking enemies is more important than exploring,-            -- and smelling actors are usually blind, so bad at exploring.-            -- TODO: prefer closer items to older smells-            smpos <- if canSmell-                     then closestSmell aid-                     else return []-            case smpos of-              [] -> do-                citems <- if EM.findWithDefault 0 AbMoveItem actorSk > 0-                          then closestItems aid-                          else return []-                case filter desirable citems of-                  [] | not (playerLeader (gplayer fact)) -> do-                    mtgtPrev <- getsClient $ getTarget aid-                    let vOld = bpos b `vectorToFrom` boldpos b-                        v = case (mtgtPrev, isUnit vOld) of-                              (Just (TVector tgtPrev), True) ->-                                if euclidDistSqVector tgtPrev vOld <= 2-                                then tgtPrev-                                else vOld-                              (Just (TVector tgtPrev), False) -> tgtPrev-                              (_, True) -> vOld-                              (_, False) -> Vector 1 1  -- south-east-                        -- Items and smells considered every 5 moves.-                        -- Thanks to sentinels, @path@ is never null.-                        path = trajectoryToPathBounded-                                 lxsize lysize (bpos b) (replicate 5 v)-                    return $! returN "tgt with no playerLeader"-                      ( TVector v-                      , Just (bpos b : path, (last path, length path)) )-                  [] -> do-                    let lidExplored = ES.member (blid b) explored-                    upos <- if lidExplored-                            then return Nothing-                            else closestUnknown aid-                    case upos of-                      Nothing -> do-                        csuspect <- if lidExplored-                                    then return []-                                    else closestSuspect aid-                        case csuspect of-                          [] -> do-                            ctriggers <--                              if EM.findWithDefault 0 AbTrigger actorSk > 0-                              then closestTriggers Nothing False aid-                              else return []-                            case ctriggers of-                              [] -> do-                                -- All stones turned, time to win or die.-                                afoes <- closestFoes allFoes aid-                                case afoes of-                                  (_, (aid2, _)) : _ ->-                                    setPath $ TEnemy aid2 False-                                  [] -> do-                                    getDistant <--                                      rndToAction $ oneOf-                                      $ [fmap (: []) . furthestKnown]-                                        ++ [ closestTriggers Nothing True-                                           | EM.size dungeon > 1 ]-                                    kpos <- getDistant aid-                                    case kpos of-                                      [] -> return reject-                                      p : _ -> setPath $ TPoint (blid b) p-                              p : _ -> setPath $ TPoint (blid b) p-                          p : _ -> setPath $ TPoint (blid b) p-                      Just p -> setPath $ TPoint (blid b) p-                  (_, (p, _)) : _ -> setPath $ TPoint (blid b) p-              (_, (p, _)) : _ -> setPath $ TPoint (blid b) p-      tellOthersNothingHere pos = do-        let f (tgt, _) = case tgt of-              TEnemyPos _ lid p _ -> p /= pos || lid /= blid b-              _ -> True-        modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)}-        pickNewTarget-      updateTgt :: Target -> PathEtc-                -> m (Strategy (Target, Maybe PathEtc))-      updateTgt oldTgt updatedPath@(_, (_, len)) = case oldTgt of-        TEnemy a _ -> do-          body <- getsState $ getActorBody a-          if not focused  -- prefers closer foes-             && a `notElem` map fst nearbyFoes  -- old one not close enough-             || blid body /= blid b  -- wrong level-             || actorDying body  -- foe already dying-          then pickNewTarget-          else if bpos body == fst (snd updatedPath)-               then return $! returN "TEnemy" (oldTgt, Just updatedPath)-                      -- The enemy didn't move since the target acquired.-                      -- If any walls were added that make the enemy-                      -- unreachable, AI learns that the hard way,-                      -- as soon as it bumps into them.-               else do-                 let p = bpos body-                 (bfs, mpath) <- getCacheBfsAndPath aid p-                 case mpath of-                   Nothing -> pickNewTarget  -- enemy became unreachable-                   Just path ->-                      return $! returN "TEnemy"-                        (oldTgt, Just ( bpos b : path-                                      , (p, fromMaybe (assert `failure` mpath)-                                            $ accessBfs bfs p) ))-        TEnemyPos _ lid p _ ->-          -- Chase last position even if foe hides or dies,-          -- to find his companions, loot, etc.-          if lid /= blid b  -- wrong level-             || chessDist (bpos b) p >= nearby  -- too far and not visible-          then pickNewTarget-          else if p == bpos b-               then tellOthersNothingHere p-               else return $! returN "TEnemyPos" (oldTgt, Just updatedPath)-        _ | not $ null nearbyFoes ->-          pickNewTarget  -- prefer close foes to anything-        TPoint lid pos -> do-          let allExplored = ES.size explored == EM.size dungeon-          if lid /= blid b  -- wrong level-             -- Below we check the target could not be picked again in-             -- pickNewTarget, and only in this case it is invalidated.-             -- This ensures targets are eventually reached (unless a foe-             -- shows up) and not changed all the time mid-route-             -- to equally interesting, but perhaps a bit closer targets,-             -- most probably already targeted by other actors.-             || (EM.findWithDefault 0 AbMoveItem actorSk <= 0  -- closestItems-                 || not (desirableBag (lvl `atI` pos)))-                && (not canSmell  -- closestSmell-                    || pos == bpos b  -- in case server resends deleted smell-                    || let sml =-                             EM.findWithDefault timeZero pos (lsmell lvl)-                       in sml `timeDeltaToFrom` ltime lvl <= Delta timeZero)-                && let t = lvl `at` pos-                   in if ES.notMember lid explored-                      then t /= unknownId  -- closestUnknown-                           && not (Tile.isSuspect cotile t)  -- closestSuspect-                      else  -- closestTriggers-                        -- Try to kill that very last enemy for his loot before-                        -- leaving the level or dungeon.-                        not (null allFoes)-                        || -- If all explored, escape/block escapes.-                           (EM.findWithDefault 0 AbTrigger actorSk <= 0-                            || not (Tile.isEscape cotile t && allExplored))-                           -- The next case is stairs in closestTriggers.-                           -- We don't determine if the stairs are interesting-                           -- (this changes with time), but allow the actor-                           -- to reach them and then retarget.-                           && not (pos /= bpos b && Tile.isStair cotile t)-                           -- The remaining case is furthestKnown. This is-                           -- always an unimportant target, so we forget it-                           -- if the actor is stuck (could move, but waits).-                           && let isStuck =-                                    waitedLastTurn b-                                    && (oldLeader == aid-                                        || isAllMoveFact cops fact)-                              in not (pos /= bpos b-                                      && not isStuck-                                      && allExplored)-          then pickNewTarget-          else return $! returN "TPoint" (oldTgt, Just updatedPath)-        TVector{} | len > 1 ->-          return $! returN "TVector" (oldTgt, Just updatedPath)-        TVector{} -> pickNewTarget-  case oldTgtUpdatedPath of-    Just (oldTgt, updatedPath) -> updateTgt oldTgt updatedPath-    Nothing -> pickNewTarget
− Game/LambdaHack/Client/AI/Preferences.hs 
@@ -1,130 +0,0 @@--- | Actor preferences for targets and actions based on actor attributes.-module Game.LambdaHack.Client.AI.Preferences-  ( totalUsefulness, effectToBenefit-  ) where--import qualified Control.Monad.State as St-import qualified Data.EnumMap.Strict as EM-import Data.Maybe--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.ItemKind---- | How much AI benefits from applying the effect. Multipllied by item p.--- Negative means harm to the enemy when thrown at him. Effects with zero--- benefit won't ever be used, neither actively nor passively.-effectToBenefit :: Kind.COps -> Actor -> [ItemFull] -> Faction-                -> Effect.Effect Int -> Int-effectToBenefit cops b activeItems fact eff =-  let isHorror = isHorrorFact cops fact-  in case eff of-    Effect.NoEffect _ -> 0-    Effect.RefillHP p ->-      let hpMax = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-      in if p > 0-         then 1 + 10 * min p (fromIntegral $ (xM hpMax - bhp b) `divUp` oneM)-         else max (-99) (10 * p)-    Effect.Hurt d -> -(min 99 $ round (10 * Dice.meanDice d))-    Effect.RefillCalm p ->-      let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems-      in if p > 0-         then 1 + min p (fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM)-         else max (-20) p-    Effect.Dominate -> -200-    Effect.Impress -> -10-    Effect.CallFriend p -> 20 * p-    Effect.Summon{} | isHorror -> 1    -- probably generates friends or crazies-    Effect.Summon{} -> 0               -- probably generates enemies-    Effect.CreateItem p -> 20 * p-    Effect.ApplyPerfume -> -10-    Effect.Burn p -> -15 * p           -- usually splash damage, etc.-    Effect.Ascend{} -> 1               -- change levels sensibly, in teams-    Effect.Escape{} -> 10000           -- AI wants to win; spawners to guard-    Effect.Paralyze p -> -20 * p-    Effect.InsertMove p -> 50 * p-    Effect.DropBestWeapon -> -50-    Effect.DropEqp ' ' False -> -80-    Effect.DropEqp ' ' True -> -100-    Effect.DropEqp _ False -> -40-    Effect.DropEqp _ True -> -50-    Effect.SendFlying _ -> -10  -- but useful on self sometimes, too-    Effect.PushActor _ -> -10  -- but useful on self sometimes, too-    Effect.PullActor _ -> -10-    Effect.Teleport p | p < 5 -> 5 * p  -- blink to shoot at foe-    Effect.Teleport p | p < 10 -> 1  -- neither escape nor repositioning-    Effect.Teleport p -> -5 * p  -- get rid of the foe-    Effect.PolyItem _ -> 0  -- AI would loop-    Effect.Identify _ -> 0  -- AI would loop-    Effect.ActivateInv ' ' -> -100-    Effect.ActivateInv _ -> -50-    Effect.Explode _ -> -10-    Effect.OneOf _ -> 1  -- usually a mixed blessing, but slightly beneficial-    Effect.OnSmash _ -> -10-    Effect.TimedAspect k asp -> k * (aspectToBenefit cops b asp) `div` 50---- | Return the value to add to effect value and another to multiply it.-aspectToBenefit :: Kind.COps -> Actor -> Effect.Aspect Int -> Int-aspectToBenefit _cops _b asp =-  case asp of-    Effect.Periodic{} -> 0-    Effect.AddMaxHP p -> p * 10-    Effect.AddMaxCalm p -> p `divUp` 2-    Effect.AddSpeed p -> p * 10000-    Effect.AddSkills m -> 5 * sum (EM.elems m)-    Effect.AddHurtMelee p -> p `divUp` 3-    Effect.AddHurtRanged p -> p `divUp` 5-    Effect.AddArmorMelee p -> p `divUp` 5-    Effect.AddArmorRanged p -> p `divUp` 10-    Effect.AddSight p -> p * 10-    Effect.AddSmell p -> p * 2-    Effect.AddLight p -> p * 10---- | Determine the total benefit from having an item in eqp or inv,--- according to item type, and also the benefit confered by equipping the item--- and from meleeing with it or applying it or throwing it.-totalUsefulness :: Kind.COps -> Actor -> [ItemFull] -> Faction -> ItemFull-                -> Maybe (Int, (Int, Int))-totalUsefulness cops b activeItems fact itemFull =-  let ben effects aspects =-        let effBens = map (effectToBenefit cops b activeItems fact) effects-            aspBens = map (aspectToBenefit cops b) aspects-            periodicEffBens =-              case strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull of-                Nothing -> []-                Just in100 -> map (\eff -> eff * in100 `div` 5) effBens-            selfBens = aspBens ++ periodicEffBens-            eqpSum = if not (null selfBens) && minimum selfBens < -10-                                            && maximum selfBens > 10-                     then 0  -- significant mixed blessings out of AI control-                     else sum selfBens-            effSum = sum effBens-            isWeapon =-              isJust (strengthFromEqpSlot Effect.EqpSlotWeapon itemFull)-            totalSum = if goesIntoInv $ itemBase itemFull-                       then effSum-                       else if isWeapon-                            then effSum + eqpSum-                            else eqpSum-        in (totalSum, (eqpSum, effSum))-  in case itemDisco itemFull of-    Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects, jeffects}} ->-      Just $ ben jeffects jaspects-    Just ItemDisco{itemKind=ItemKind{iaspects, ieffects}} ->-      let travA x =-            St.evalState (Effect.aspectTrav x (return . round . Dice.meanDice))-                         ()-          jaspects = map travA iaspects-          travE x =-            St.evalState (Effect.effectTrav x (return . round . Dice.meanDice))-                         ()-          jeffects = map travE ieffects-      in Just $ ben jeffects jaspects-    _ -> Nothing
− Game/LambdaHack/Client/AI/Strategy.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | AI strategies to direct actors not controlled directly by human players.--- No operation in this module involves the 'State' or 'Action' type.-module Game.LambdaHack.Client.AI.Strategy-  ( Strategy, nullStrategy, liftFrequency-  , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN, mapStrategyM-  ) where--import Control.Applicative-import Control.Monad-import Data.Maybe-import Data.Text (Text)--import Game.LambdaHack.Common.Frequency as Frequency-import Game.LambdaHack.Common.Msg---- | A strategy is a choice of (non-empty) frequency tables--- of possible actions.-newtype Strategy a = Strategy { runStrategy :: [Frequency a] }-  deriving Show---- | Strategy is a monad. TODO: Can we write this as a monad transformer?-instance Monad Strategy where-  {-# INLINE return #-}-  return x = Strategy $ return $! uniformFreq "Strategy_return" [x]-  m >>= f  = normalizeStrategy $ Strategy-    [ toFreq name [ (p * q, b)-                  | (p, a) <- runFrequency x-                  , y <- runStrategy (f a)-                  , (q, b) <- runFrequency y-                  ]-    | x <- runStrategy m-    , let name = "Strategy_bind (" <> nameFrequency x <> ")"]--instance Functor Strategy where-  fmap f (Strategy fs) = Strategy (map (fmap f) fs)--instance Applicative Strategy where-  pure  = return-  (<*>) = ap--instance MonadPlus Strategy where-  mzero = Strategy []-  {-# INLINE mplus #-}-  mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)--instance Alternative Strategy where-  (<|>) = mplus-  empty = mzero--normalizeStrategy :: Strategy a -> Strategy a-normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs--nullStrategy :: Strategy a -> Bool-nullStrategy strat = null $ runStrategy strat---- | Strategy where only the actions from the given single frequency table--- can be picked.-liftFrequency :: Frequency a -> Strategy a-liftFrequency f = normalizeStrategy $ Strategy $ return f--infixr 2 .|---- | Strategy with the actions from both argument strategies,--- with original frequencies.-(.|) :: Strategy a -> Strategy a -> Strategy a-(.|) = mplus---- | Strategy with no actions at all.-reject :: Strategy a-reject = mzero--infix 3 .=>---- | Conditionally accepted strategy.-(.=>) :: Bool -> Strategy a -> Strategy a-p .=> m | p         = m-        | otherwise = mzero---- | Strategy with all actions not satisfying the predicate removed.--- The remaining actions keep their original relative frequency values.-only :: (a -> Bool) -> Strategy a -> Strategy a-only p s = normalizeStrategy $ do-  x <- s-  p x .=> return x---- | When better choices are towards the start of the list,--- this is the best frequency of the strategy.-bestVariant :: Strategy a -> Frequency a-bestVariant (Strategy []) = mzero-bestVariant (Strategy (f : _)) = f---- | Overwrite the description of all frequencies within the strategy.-renameStrategy :: Text -> Strategy a -> Strategy a-renameStrategy newName (Strategy fs) = Strategy $ map (renameFreq newName) fs---- | Like 'return', but pick a name of the single frequency.-returN :: Text -> a -> Strategy a-returN name x = Strategy $ return $! uniformFreq name [x]--mapStrategyM :: Monad m => (a -> m (Maybe b)) -> Strategy a -> m (Strategy b)-mapStrategyM f s = do-  let mapFreq freq = do-        let g (k, a) = do-              mb <- f a-              return $! (k,) <$> mb-        lbm <- mapM g $ runFrequency freq-        return $! toFreq "mapStrategyM" $ catMaybes lbm-      ls = runStrategy s-  lt <- mapM mapFreq ls-  return $! normalizeStrategy $ Strategy lt
− Game/LambdaHack/Client/Bfs.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Breadth first search algorithms.-module Game.LambdaHack.Client.Bfs-  ( -- * Public API-    BfsDistance, MoveLegal(..), apartBfs-  , fillBfs, findPathBfs, accessBfs-    -- * Internal functions-  , minKnownBfs-  ) where--import Control.Arrow (second)-import Control.Exception.Assert.Sugar-import Data.Binary-import Data.Bits (Bits, complement, (.&.), (.|.))-import Data.List-import Data.Maybe-import qualified Data.Sequence as Seq--import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Vector---- | Weighted distance between points along shortest paths.-newtype BfsDistance = BfsDistance Word8-  deriving (Show, Eq, Ord, Enum, Bounded, Bits)---- | State of legality of moves between adjacent points.-data MoveLegal = MoveBlocked | MoveToOpen | MoveToUnknown-  deriving Eq---- | The minimal distance value assigned to paths that don't enter--- any unknown tiles.-minKnownBfs :: BfsDistance-minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2---- | The distance value that denote no legal path between points.-apartBfs :: BfsDistance-apartBfs = pred minKnownBfs---- | Fill out the given BFS array.-fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is a move from known tile legal-        -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal-        -> Point                          -- ^ starting position-        -> PointArray.Array BfsDistance   -- ^ initial array, with @apartBfs@-        -> PointArray.Array BfsDistance   -- ^ array with calculated distances-fillBfs isEnterable passUnknown origin aInitial =-  let maxUnknownBfs = pred apartBfs-      maxKnownBfs = pred maxBound-      bfs :: Seq.Seq (Point, BfsDistance)-          -> PointArray.Array BfsDistance-          -> PointArray.Array BfsDistance-      bfs q a =-        case Seq.viewr q of-          Seq.EmptyR -> a  -- no more positions to check-          _ Seq.:> (_, d)-            | d == maxUnknownBfs || d == maxKnownBfs -> a  -- too far-          q1 Seq.:> (pos, oldDistance) | oldDistance >= minKnownBfs ->-            let distance = succ oldDistance-                allMvs = map (shift pos) moves-                freshMv p = a PointArray.! p == apartBfs-                freshMvs = filter freshMv allMvs-                legal p = (p, isEnterable pos p)-                legalities = map legal freshMvs-                notBlocked = filter ((/= MoveBlocked) . snd) legalities-                legalToDist l = if l == MoveToOpen-                                then distance-                                else distance .&. complement minKnownBfs-                mvs = map (second legalToDist) notBlocked-                q2 = foldr (Seq.<|) q1 mvs-                s2 = a PointArray.// mvs-            in bfs q2 s2-          q1 Seq.:> (pos, oldDistance) ->-            let distance = succ oldDistance-                allMvs = map (shift pos) moves-                goodMv p = a PointArray.! p == apartBfs && passUnknown pos p-                mvs = zip (filter goodMv allMvs) (repeat distance)-                q2 = foldr (Seq.<|) q1 mvs-                s2 = a PointArray.// mvs-            in bfs q2 s2-      origin0 = (origin, minKnownBfs)-  in bfs (Seq.singleton origin0) (aInitial PointArray.// [origin0])---- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/--- to determine a few really different paths and compare them,--- e.g., how many closed doors they pass, open doors, unknown tiles--- on the path or close enough to reveal them.--- Also, check if JPS can somehow optimize BFS or pathBfs.--- | Find a path, without the source position, with the smallest length.--- The @eps@ coefficient determines which direction (or the closest--- directions available) that path should prefer, where 0 means north-west--- and 1 means north.-findPathBfs :: (Point -> Point -> MoveLegal)-            -> (Point -> Point -> Bool)-            -> Point -> Point -> Int -> PointArray.Array BfsDistance-            -> Maybe [Point]-findPathBfs isEnterable passUnknown source target sepsRaw bfs =-  assert (bfs PointArray.! source == minKnownBfs) $-  let targetDist = bfs PointArray.! target-  in if targetDist == apartBfs-     then Nothing-     else-       let eps = sepsRaw `mod` 4-           (mc1, mc2) = splitAt eps movesCardinal-           (md1, md2) = splitAt eps movesDiagonal-           preferredMoves = mc1 ++ reverse mc2 ++ md2 ++ reverse md1  -- fuzz-           track :: Point -> BfsDistance -> [Point] -> [Point]-           track pos oldDist suffix | oldDist == minKnownBfs =-             assert (pos == source-                     `blame` (source, target, pos, suffix)) suffix-           track pos oldDist suffix | oldDist > minKnownBfs =-             let dist = pred oldDist-                 children = map (shift pos) preferredMoves-                 matchesDist p = bfs PointArray.! p == dist-                                 && isEnterable p pos == MoveToOpen-                 minP = fromMaybe (assert `failure` (pos, oldDist, children))-                                  (find matchesDist children)-             in track minP dist (pos : suffix)-           track pos oldDist suffix =-             let distUnknown = pred oldDist-                 distKnown = distUnknown .|. minKnownBfs-                 children = map (shift pos) preferredMoves-                 matchesDistUnknown p = bfs PointArray.! p == distUnknown-                                        && passUnknown p pos-                 matchesDistKnown p = bfs PointArray.! p == distKnown-                                      && isEnterable p pos == MoveToUnknown-                 (minP, dist) = case find matchesDistKnown children of-                   Just p -> (p, distKnown)-                   Nothing -> case find matchesDistUnknown children of-                     Just p -> (p, distUnknown)-                     Nothing -> assert `failure` (pos, oldDist, children)-             in track minP dist (pos : suffix)-       in Just $ track target targetDist []---- | Access a BFS array and interpret the looked up distance value.-accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int-{-# INLINE accessBfs #-}-accessBfs bfs target =-  let dist = bfs PointArray.! target-  in if dist == apartBfs-     then Nothing-     else Just $ fromEnum $ dist .&. complement minKnownBfs
− Game/LambdaHack/Client/BfsClient.hs 
@@ -1,299 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Breadth first search and realted algorithms using the client monad.-module Game.LambdaHack.Client.BfsClient-  ( getCacheBfsAndPath, getCacheBfs, accessCacheBfs-  , unexploredDepth, closestUnknown, closestSuspect, closestSmell, furthestKnown-  , closestTriggers, closestItems, closestFoes-  ) where--import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Ord--import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.TileKind---- | Get cached BFS data and path or, if not stored, generate,--- store and return. Due to laziness, they are not calculated until needed.-getCacheBfsAndPath :: forall m. MonadClient m-                   => ActorId -> Point-                   -> m (PointArray.Array BfsDistance, Maybe [Point])-getCacheBfsAndPath aid target = do-  seps <- getsClient seps-  let pathAndStore :: PointArray.Array BfsDistance-                   -> m (PointArray.Array BfsDistance, Maybe [Point])-      pathAndStore bfs = do-        computePath <- computePathBFS aid-        let mpath = computePath target seps bfs-        modifyClient $ \cli ->-          cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)}-        return (bfs, mpath)-  mbfs <- getsClient $ EM.lookup aid . sbfsD-  case mbfs of-    Just (bfs, targetOld, sepsOld, mpath) | targetOld == target-                                            && sepsOld == seps ->-      return (bfs, mpath)-    Just (bfs, _, _, _) -> pathAndStore bfs-    Nothing -> do-      bfs <- computeBFS aid-      pathAndStore bfs--getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)-{-# INLINE getCacheBfs #-}-getCacheBfs aid = do-  mbfs <- getsClient $ EM.lookup aid . sbfsD-  case mbfs of-    Just (bfs, _, _, _) -> return bfs-    Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0)--computeBFS :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)-computeBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do-  b <- getsState $ getActorBody aid-  Level{lxsize, lysize} <- getLevel $ blid b-  let origin = bpos b-      vInitial = PointArray.replicateA lxsize lysize apartBfs-  -- Here we don't want '$!', because we want the BFS data lazy.-  return ${-keep it!-} fillBfs isEnterable passUnknown origin vInitial--computePathBFS :: MonadClient m-               => ActorId-               -> m (Point -> Int -> PointArray.Array BfsDistance-                     -> Maybe [Point])-computePathBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do-  b <- getsState $ getActorBody aid-  let origin = bpos b-  -- Here we don't want '$!', because we want the BFS data lazy.-  return ${-keep it!-} findPathBfs isEnterable passUnknown origin--computeAnythingBFS :: MonadClient m-                   => ((Point -> Point -> MoveLegal)-                       -> (Point -> Point -> Bool)-                       -> ActorId-                       -> m a)-                   -> ActorId-                   -> m a-computeAnythingBFS fAnything aid = do-  cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops-  b <- getsState $ getActorBody aid-  mleader <- getsClient _sleader-  actorSk <- actorSkillsClient aid mleader  -- TODO: reset BFS at leader change?-  lvl <- getLevel $ blid b-  -- We treat doors as an open tile and don't add an extra step for opening-  -- the doors, because other actors open and use them, too,-  -- so it's amortized. We treat unknown tiles specially.-  let unknownId = ouniqGroup "unknown space"-      chAccess = checkAccess cops lvl-      canOpenDoors = EM.findWithDefault 0 Ability.AbAlter actorSk > 0-      chDoorAccess = if canOpenDoors then [checkDoorAccess cops lvl] else []-      conditions = catMaybes $ chAccess : chDoorAccess-      -- Legality of move from a known tile, assuming doors freely openable.-      isEnterable :: Point -> Point -> MoveLegal-      isEnterable spos tpos =-        let st = lvl `at` spos-            tt = lvl `at` tpos-            allOK = all (\f -> f spos tpos) conditions-        in if tt == unknownId-           then if not (Tile.isSuspect cotile st) && allOK-                then MoveToUnknown-                else MoveBlocked-           else if Tile.isPassable cotile tt-                   && not (Tile.isChangeable cotile st)  -- takes time to change-                   && allOK-                then MoveToOpen-                else MoveBlocked-      -- Legality of move from an unknown tile, assuming unknown are open.-      passUnknown :: Point -> Point -> Bool-      passUnknown = case chAccess of  -- spos is unknown, so not a door-        Nothing -> \_ tpos -> let tt = lvl `at` tpos-                              in tt == unknownId-        Just ch -> \spos tpos -> let tt = lvl `at` tpos-                                 in tt == unknownId-                                    && ch spos tpos-  fAnything isEnterable passUnknown aid--accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)-{-# INLINE accessCacheBfs #-}-accessCacheBfs aid target = do-  bfs <- getCacheBfs aid-  return $! accessBfs bfs target---- | Furthest (wrt paths) known position.-furthestKnown :: MonadClient m => ActorId -> m Point-furthestKnown aid = do-  bfs <- getCacheBfs aid-  getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA-                                     , PointArray.maxLastIndexA ]-  let furthestPos = getMaxIndex bfs-      dist = bfs PointArray.! furthestPos-  return $! if dist <= apartBfs-            then assert `failure` (aid, furthestPos, dist)-            else furthestPos---- | Closest reachable unknown tile position, if any.-closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)-closestUnknown aid = do-  bfs <- getCacheBfs aid-  getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA-                                     , PointArray.minLastIndexA ]-  let closestPos = getMinIndex bfs-      dist = bfs PointArray.! closestPos-  if dist >= apartBfs then do-    body <- getsState $ getActorBody aid-    lvl <- getLevel $ blid body-    when (lclear lvl == lseen lvl) $ do  -- explored fully, mark it once for all-      assert (lclear lvl >= lseen lvl) skip-      modifyClient $ \cli ->-        cli {sexplored = ES.insert (blid body) (sexplored cli)}-    return Nothing-  else return $ Just closestPos---- TODO: this is costly, because target has to be changed every--- turn when walking along trail. But inverting the sort and going--- to the newest smell, while sometimes faster, may result in many--- actors following the same trail, unless we wipe the trail as soon--- as target is assigned (but then we don't know if we should keep the target--- or not, because somebody already followed it). OTOH, trails are not--- common and so if wiped they can't incur a large total cost.--- TODO: remove targets where the smell is likely to get too old by the time--- the actor gets there.--- | Finds smells closest to the actor, except under the actor.-closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))]-closestSmell aid = do-  body <- getsState $ getActorBody aid-  Level{lsmell} <- getLevel $ blid body-  let smells = EM.assocs lsmell-  case smells of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells-          ds = filter (\(d, _) -> d /= 0) ts  -- bpos of aid-      return $! sortBy (comparing (fst &&& absoluteTimeNegate . snd . snd)) ds---- | Closest (wrt paths) suspect tile.-closestSuspect :: MonadClient m => ActorId -> m [Point]-closestSuspect aid = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  lvl <- getLevel $ blid body-  let f :: [Point] -> Point -> Kind.Id TileKind -> [Point]-      f acc p t = if Tile.isSuspect cotile t then p : acc else acc-      suspect = PointArray.ifoldlA f [] $ ltile lvl-  case suspect of-    [] -> do-      -- If the level has inaccessible open areas (at least from some stairs)-      -- here finally mark it explored, to enable transition to other levels.-      -- We should generally avoid such levels, because digging and/or trying-      -- to find other stairs leading to disconnected areas is not KISS-      -- so we don't do this in AI, so AI is at a disadvantage.-      modifyClient $ \cli ->-        cli {sexplored = ES.insert (blid body) (sexplored cli)}-      return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) suspect-      return $! map snd $ sortBy (comparing fst) ds---- TODO: We assume linear dungeon in @unexploredD@,--- because otherwise we'd need to calculate shortest paths in a graph, etc.--- | Closest (wrt paths) triggerable open tiles.--- The second argument can ever be true only if there's--- no escape from the dungeon.-closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point]-closestTriggers onlyDir exploredToo aid = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  lvl <- getLevel $ blid body-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  unexploredD <- unexploredDepth-  let allExplored = ES.size explored == EM.size dungeon-      unexUp = onlyDir /= Just False && unexploredD 1 (blid body)-      unexDown = onlyDir /= Just True && unexploredD (-1) (blid body)-      unexEffect (Effect.Ascend p) = if p > 0 then unexUp else unexDown-      unexEffect _ =-        -- Escape (or guard) only after exploring, for high score, etc.-        allExplored-      isTrigger-        | exploredToo = \t -> Tile.isWalkable cotile t-                              && not (null $ Tile.causeEffects cotile t)-        | otherwise = \t -> Tile.isWalkable cotile t-                            && any unexEffect (Tile.causeEffects cotile t)-      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]-      f acc p t = if isTrigger t then p : acc else acc-  let triggersAll = PointArray.ifoldlA f [] $ ltile lvl-      -- Don't target stairs under the actor. Most of the time they-      -- are blocked and stay so, so we seek other stairs, if any.-      -- If no other stairs in this direction, let's wait here.-      triggers | length triggersAll > 1 = delete (bpos body) triggersAll-               | otherwise = triggersAll-  case triggers of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) triggers-      return $! map snd $ sortBy (comparing fst) ds--unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)-unexploredDepth = do-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  let allExplored = ES.size explored == EM.size dungeon-      unexploredD p =-        let unex lid = allExplored && lescape (dungeon EM.! lid)-                       || ES.notMember lid explored-                       || unexploredD p lid-        in any unex . ascendInBranch dungeon p-  return unexploredD---- | Closest (wrt paths) items and changeable tiles (e.g., item caches).-closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, Maybe ItemBag))])-closestItems aid = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  lvl@Level{lfloor} <- getLevel $ blid body-  let items = EM.assocs lfloor-      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]-      f acc p t = if Tile.isChangeable cotile t then p : acc else acc-      changeable = PointArray.ifoldlA f [] $ ltile lvl-  if null items && null changeable then return []-  else do-    bfs <- getCacheBfs aid-    let is = mapMaybe (\(p, bag) ->-                        fmap (, (p, Just bag)) (accessBfs bfs p)) items-        cs = mapMaybe (\p ->-                        fmap (, (p, Nothing)) (accessBfs bfs p)) changeable-    return $! sortBy (comparing fst) $ is ++ cs---- | Closest (wrt paths) enemy actors.-closestFoes :: MonadClient m-            => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]-closestFoes foes aid = do-  case foes of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes-      return $! sortBy (comparing fst) ds
− Game/LambdaHack/Client/CommonClient.hs 
@@ -1,243 +0,0 @@-{-# LANGUAGE DataKinds #-}--- | Common client monad operations.-module Game.LambdaHack.Client.CommonClient-  ( getPerFid, aidTgtToPos, aidTgtAims, makeLine-  , partAidLeader, partActorLeader, partPronounLeader-  , actorSkillsClient, updateItemSlot, fullAssocsClient, activeItemsClient-  , itemToFullClient, pickWeaponClient, sumOrganEqpClient, getModeClient-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM-import qualified Data.IntMap.Strict as IM-import Data.Maybe-import Data.Text (Text)-import Data.Tuple-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.ItemSlot-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ModeKind---- | Get the current perception of a client.-getPerFid :: MonadClient m => LevelId -> m Perception-getPerFid lid = do-  fper <- getsClient sfper-  return $! fromMaybe (assert `failure` "no perception at given level"-                              `twith` (lid, fper))-                      $ EM.lookup lid fper---- | The part of speech describing the actor or "you" if a leader--- of the client's faction. The actor may be not present in the dungeon.-partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part-partActorLeader aid b = do-  mleader <- getsClient _sleader-  return $! case mleader of-    Just leader | aid == leader -> "you"-    _ -> partActor b---- | The part of speech with the actor's pronoun or "you" if a leader--- of the client's faction. The actor may be not present in the dungeon.-partPronounLeader :: MonadClient m => ActorId -> Actor -> m MU.Part-partPronounLeader aid b = do-  mleader <- getsClient _sleader-  return $! case mleader of-    Just leader | aid == leader -> "you"-    _ -> partPronoun 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---- | Calculate the position of an actor's target.-aidTgtToPos :: MonadClient m-            => ActorId -> LevelId -> Maybe Target -> m (Maybe Point)-aidTgtToPos aid lidV tgt =-  case tgt of-    Just (TEnemy a _) -> do-      body <- getsState $ getActorBody a-      return $! if blid body == lidV-                then Just (bpos body)-                else Nothing-    Just (TEnemyPos _ lid p _) ->-      return $! if lid == lidV then Just p else Nothing-    Just (TPoint lid p) ->-      return $! if lid == lidV then Just p else Nothing-    Just (TVector v) -> do-      b <- getsState $ getActorBody aid-      Level{lxsize, lysize} <- getLevel lidV-      let shifted = shiftBounded lxsize lysize (bpos b) v-      return $! if shifted == bpos b && v /= Vector 0 0-                then Nothing-                else Just shifted-    Nothing -> do-      scursor <- getsClient scursor-      aidTgtToPos aid lidV $ Just scursor---- | Check whether one is permitted to aim at a target--- (this is only checked for actors; positions let player--- shoot at obstacles, e.g., to destroy them).--- This assumes @aidTgtToPos@ does not return @Nothing@.--- Returns a different @seps@, if needed to reach the target actor.------ Note: Perception is not enough for the check,--- because the target actor can be obscured by a glass wall--- or be out of sight range, but in weapon range.-aidTgtAims :: MonadClient m-           => ActorId -> LevelId -> Maybe Target -> m (Either Text Int)-aidTgtAims aid lidV tgt = do-  oldEps <- getsClient seps-  case tgt of-    Just (TEnemy a _) -> do-      body <- getsState $ getActorBody a-      let pos = bpos body-      b <- getsState $ getActorBody aid-      if blid b == lidV then do-        mnewEps <- makeLine b pos oldEps-        case mnewEps of-          Just newEps -> return $ Right newEps-          Nothing -> return $ Left "aiming line to the opponent blocked"-      else return $ Left "target opponent not on this level"-    Just TEnemyPos{} -> return $ Left "target opponent not visible"-    Just TPoint{} -> return $ Right oldEps-    Just TVector{} -> return $ Right oldEps-    Nothing -> do-      scursor <- getsClient scursor-      aidTgtAims aid lidV $ Just scursor---- | Counts the number of steps until the projectile would hit--- an actor or obstacle. Starts searching with the given eps and returns--- the first found eps for which the number reaches the distance between--- actor and target position, or Nothing if none can be found.-makeLine :: MonadClient m => Actor -> Point -> Int -> m (Maybe Int)-makeLine body fpos epsOld = do-  cops@Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops-  lvl@Level{lxsize, lysize} <- getLevel (blid body)-  bs <- getsState $ filter (not . bproj)-                    . actorList (const True) (blid body)-  let unknownId = ouniqGroup "unknown space"-      dist = chessDist (bpos body) fpos-      calcScore eps = case bla lxsize lysize eps (bpos body) fpos of-        Just bl ->-          let blDist = take dist bl-              blZip = zip (bpos body : blDist) blDist-              noActor p = all ((/= p) . bpos) bs || p == fpos-              accessU = all noActor blDist-                        && all (uncurry $ accessibleUnknown cops lvl) blZip-              nUnknown = length $ filter ((== unknownId) . (lvl `at`)) blDist-          in if accessU then - nUnknown else minBound-        Nothing -> assert `failure` (body, fpos, epsOld)-      tryLines curEps (acc, _) | curEps >= epsOld + dist = acc-      tryLines curEps (acc, bestScore) =-        let curScore = calcScore curEps-            newAcc = if curScore > bestScore-                     then (Just curEps, curScore)-                     else (acc, bestScore)-        in tryLines (curEps + 1) newAcc-  return $! if dist <= 1-            then Nothing  -- ProjectBlockActor, ProjectAimOnself-            else tryLines epsOld (Nothing, minBound)--actorSkillsClient :: MonadClient m-                  => ActorId -> Maybe ActorId -> m Ability.Skills-actorSkillsClient aid mleader = do-  activeItems <- activeItemsClient aid-  getsState $ actorSkills aid mleader activeItems--updateItemSlot :: MonadClient m => Maybe ActorId -> ItemId -> m ()-updateItemSlot maid iid = do-  slots@(letterSlots, numberSlots) <- getsClient sslots-  case ( lookup iid $ map swap $ EM.assocs letterSlots-       , lookup iid $ map swap $ IM.assocs numberSlots ) of-    (Nothing, Nothing) -> do-      side <- getsClient sside-      item <- getsState $ getItemBody iid-      lastSlot <- getsClient slastSlot-      mb <- maybe (return Nothing) (fmap Just . getsState . getActorBody) maid-      el <- getsState $ assignSlot item side mb slots lastSlot-      case el of-        Left l ->-          modifyClient $ \cli ->-            cli { sslots = (EM.insert l iid letterSlots, numberSlots)-                , slastSlot = max l (slastSlot cli) }-        Right l ->-          modifyClient $ \cli ->-            cli { sslots = (letterSlots, IM.insert l iid numberSlots) }-    _ -> return ()  -- slot already assigned; a letter or a number--fullAssocsClient :: MonadClient m-                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]-fullAssocsClient aid cstores = do-  cops <- getsState scops-  disco <- getsClient sdisco-  discoAE <- getsClient sdiscoAE-  getsState $ fullAssocs cops disco discoAE aid cstores--activeItemsClient :: MonadClient m => ActorId -> m [ItemFull]-activeItemsClient aid = do-  activeAssocs <- fullAssocsClient aid [CEqp, COrgan]-  return $! map snd activeAssocs--itemToFullClient :: MonadClient m => m (ItemId -> Int -> ItemFull)-itemToFullClient = do-  cops <- getsState scops-  disco <- getsClient sdisco-  discoAE <- getsClient sdiscoAE-  s <- getState-  let itemToF iid = itemToFull cops disco discoAE iid (getItemBody iid s)-  return itemToF---- Client has to choose the weapon based on its partial knowledge,--- because if server chose it, it would leak item discovery information.-pickWeaponClient :: MonadClient m-                 => ActorId -> ActorId -> m [RequestTimed Ability.AbMelee]-pickWeaponClient source target = do-  eqpAssocs <- fullAssocsClient source [CEqp]-  bodyAssocs <- fullAssocsClient source [COrgan]-  mleader <- getsClient _sleader-  actorSk <- actorSkillsClient source mleader-  let allAssocs = eqpAssocs ++ bodyAssocs-  case filter (not . unknownPrecious . snd . snd)-       $ strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of-    _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return []-    [] -> return []-    iis@((maxS, _) : _) -> do-      let maxIis = map snd $ takeWhile ((== maxS) . fst) iis-      -- TODO: pick the item according to the frequency of its kind.-      (iid, _) <- rndToAction $ oneOf maxIis-      -- Prefer COrgan, to hint to the player to trash the equivalent CEqp item.-      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp-      return $! [ReqMelee target iid cstore]--sumOrganEqpClient :: MonadClient m-                  => Effect.EqpSlot -> ActorId -> m Int-sumOrganEqpClient eqpSlot aid = do-  activeItems <- activeItemsClient aid-  return $! sumSlotNoFilter eqpSlot activeItems--getModeClient :: MonadClient m => m ModeKind-getModeClient = do-  Kind.COps{comode=Kind.Ops{okind, ouniqGroup}} <- getsState scops-  t <- getsClient sgameMode-  return $! okind $ ouniqGroup t
− Game/LambdaHack/Client/HandleAtomicClient.hs 
@@ -1,390 +0,0 @@--- | Handle atomic commands received by the client.-module Game.LambdaHack.Client.HandleAtomicClient-  ( cmdAtomicSemCli, cmdAtomicFilterCli-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Maybe-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.TileKind---- * RespUpdAtomicAI---- | Clients keep a subset of atomic commands sent by the server--- and add some of their own. The result of this function is the list--- of commands kept for each command received.-cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]-cmdAtomicFilterCli cmd = case cmd of-  UpdMoveActor aid _ toP -> do-    cmdSml <- deleteSmell aid toP-    return $ [cmd] ++ cmdSml-  UpdDisplaceActor source target -> do-    bs <- getsState $ getActorBody source-    bt <- getsState $ getActorBody target-    cmdSource <- deleteSmell source (bpos bt)-    cmdTarget <- deleteSmell target (bpos bs)-    return $ [cmd] ++ cmdSource ++ cmdTarget-  UpdAlterTile lid p fromTile toTile -> do-    Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops-    lvl <- getLevel lid-    let t = lvl `at` p-    if t == fromTile-      then return [cmd]-      else do-        -- From @UpdAlterTile@ we know @t == freshClientTile@,-        -- which is uncanny, so we produce a message.-        -- It happens when a client thinks the tile is @t@,-        -- but it's @fromTile@, and @UpdAlterTile@ changes it-        -- to @toTile@. See @updAlterTile@.-        let subject = ""  -- a hack, we we don't handle adverbs well-            verb = "turn into"-            msg = makeSentence [ "the", MU.Text $ tname $ okind t-                               , "at position", MU.Text $ tshow p-                               , "suddenly"  -- adverb-                               , MU.SubjectVerbSg subject verb-                               , MU.AW $ MU.Text $ tname $ okind toTile ]-        return [ cmd  -- reveal the tile-               , UpdMsgAll msg  -- show the message-               ]-  UpdSearchTile aid p fromTile toTile -> do-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    let t = lvl `at` p-    return $!-      if t == fromTile-      then -- Fully ignorant. (No intermediate knowledge possible.)-           [ cmd  -- show the message-           , UpdAlterTile (blid b) p fromTile toTile  -- reveal tile-           ]-      else if t == toTile-           then [cmd]  -- Already knows the tile fully, only confirm.-           else -- Misguided.-                assert `failure` "LoseTile fails to reset memory"-                       `twith` (aid, p, fromTile, toTile, b, t, cmd)-  UpdLearnSecrets aid fromS _toS -> do-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    return $! if lsecret lvl == fromS-              then [cmd]  -- secrets revealed now-              else []  -- secrets already revealed previously-  UpdSpotTile lid ts -> do-    Kind.COps{cotile} <- getsState scops-    lvl <- getLevel lid-    -- We ignore the server resending us hidden versions of the tiles-    -- (and resending us the same data we already got).-    -- If the tiles are changed to other variants of the hidden tile,-    -- we can still verify by searching, and the UI warns us "obscured".-    let notKnown (p, t) = let tClient = lvl `at` p-                          in t /= tClient-                             && (not (knownLsecret lvl && isSecretPos lvl p)-                                 || t /= Tile.hideAs cotile tClient)-        newTs = filter notKnown ts-    return $! if null newTs then [] else [UpdSpotTile lid newTs]-  UpdAlterSmell lid p fromSm _toSm -> do-    lvl <- getLevel lid-    let msml = EM.lookup p $ lsmell lvl-    return $ if msml /= fromSm then-               -- Revert to the server smell before server command executes.-               -- This is needed due to our hacky removal of traversed smells-               -- in @deleteSmell@.-               [UpdAlterSmell lid p msml fromSm, cmd]-             else-               [cmd]-  UpdDiscover lid p iid _ seed -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        disco <- getsClient sdisco-        if jkindIx item `EM.member` disco-          then do-            discoAE <- getsClient sdiscoAE-            if iid `EM.member` discoAE-              then return []-              else return [UpdDiscoverSeed lid p iid seed]-          else return [cmd]-  UpdCover lid p iid ik _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        disco <- getsClient sdisco-        if jkindIx item `EM.notMember` disco-          then return []-          else do-            discoAE <- getsClient sdiscoAE-            if iid `EM.notMember` discoAE-              then return [cmd]-              else return [UpdCoverKind lid p iid ik]-  UpdDiscoverKind _ _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        disco <- getsClient sdisco-        if jkindIx item `EM.notMember` disco-        then return []-        else return [cmd]-  UpdCoverKind _ _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        disco <- getsClient sdisco-        if jkindIx item `EM.notMember` disco-        then return []-        else return [cmd]-  UpdDiscoverSeed _ _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        disco <- getsClient sdisco-        if jkindIx item `EM.notMember` disco-        then return []-        else do-          discoAE <- getsClient sdiscoAE-          if iid `EM.member` discoAE-            then return []-            else return [cmd]-  UpdCoverSeed _ _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        disco <- getsClient sdisco-        if jkindIx item `EM.notMember` disco-        then return []-        else do-          discoAE <- getsClient sdiscoAE-          if iid `EM.notMember` discoAE-            then return []-            else return [cmd]-  UpdPerception lid outPer inPer -> do-    -- Here we cheat by setting a new perception outright instead of-    -- in @cmdAtomicSemCli@, to avoid computing perception twice.-    -- TODO: try to assert similar things as for @atomicRemember@:-    -- that posUpdAtomic of all the Lose* commands was visible in old Per,-    -- but is not visible any more.-    perOld <- getPerFid lid-    perception lid outPer inPer-    perNew <- getPerFid lid-    s <- getState-    fid <- getsClient sside-    -- Wipe out actors that just became invisible due to changed FOV.-    -- TODO: perhaps instead create LoseActor for all actors in lprio,-    -- and keep only those where seenAtomicCli is True; this is even-    -- cheaper than repeated posToActor (until it's optimized).-    let outFov = totalVisible perOld ES.\\ totalVisible perNew-        outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov-        fActor ((aid, b), ais) =-          -- TODO: instead of bproj, check that actor sees himself.-          if not (bproj b) && bfid b == fid-          then Nothing  -- optimization: the actor is soon lost anyway,-                        -- e.g., via domination, so don't bother-          else Just $ UpdLoseActor aid b ais-        outActor = mapMaybe fActor outPrio-    -- Wipe out remembered items on tiles that now came into view.-    Level{lfloor, lsmell} <- getLevel lid-    let inFov = totalVisible perNew ES.\\ totalVisible perOld-        pMaybe p = maybe Nothing (\x -> Just (p, x))-        inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p lfloor)-                           (ES.elems inFov)-        fItem p (iid, k) = UpdLoseItem iid (getItemBody iid s) k (CFloor lid p)-        fBag (p, bag) = map (fItem p) $ EM.assocs bag-        inItem = concatMap fBag inFloor-    -- Remembered map tiles not wiped out, due to optimization in @updSpotTile@.-    -- Wipe out remembered smell on tiles that now came into smell Fov.-    let inSmellFov = smellVisible perNew ES.\\ smellVisible perOld-        inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p lsmell)-                        (ES.elems inSmellFov)-        inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]-    let seenNew = seenAtomicCli False fid perNew-        seenOld = seenAtomicCli False fid perOld-    -- TODO: these assertions are probably expensive-    psActor <- mapM posUpdAtomic outActor-    -- Verify that we forget only previously seen actors.-    assert (allB seenOld psActor) skip-    -- Verify that we forget only currently invisible actors.-    assert (allB (not . seenNew) psActor) skip-    psItemSmell <- mapM posUpdAtomic $ inItem ++ inSmell-    -- Verify that we forget only previously invisible items and smell.-    assert (allB (not . seenOld) psItemSmell) skip-    -- Verify that we forget only currently seen items and smell.-    assert (allB seenNew psItemSmell) skip-    return $! cmd : outActor ++ inItem ++ inSmell-  _ -> return [cmd]--deleteSmell :: MonadClient m => ActorId -> Point -> m [UpdAtomic]-deleteSmell aid pos = do-  b <- getsState $ getActorBody aid-  smellRadius <- sumOrganEqpClient Effect.EqpSlotAddSmell aid-  if smellRadius <= 0 then return []-  else do-    lvl <- getLevel $ blid b-    let msml = EM.lookup pos $ lsmell lvl-    return $-      maybe [] (\sml -> [UpdAlterSmell (blid b) pos (Just sml) Nothing]) msml---- | Effect of atomic actions on client state is calculated--- in the global state before the command is executed.-cmdAtomicSemCli :: MonadClient m => UpdAtomic -> m ()-cmdAtomicSemCli cmd = case cmd of-  UpdCreateActor aid body _ -> createActor aid body-  UpdDestroyActor aid b _ -> destroyActor aid b True-  UpdSpotActor aid body _ -> createActor aid body-  UpdLoseActor aid b _ -> destroyActor aid b False-  UpdLeadFaction fid source target -> do-    side <- getsClient sside-    when (side == fid) $ do-      mleader <- getsClient _sleader-      assert (mleader == source     -- somebody changed the leader for us-              || mleader == target  -- we changed the leader originally-              `blame` "unexpected leader" `twith` (cmd, mleader)) skip-      modifyClient $ \cli -> cli {_sleader = target}-  UpdDiscover lid p iid ik seed -> do-    discoverKind lid p iid ik-    discoverSeed lid p iid seed-  UpdCover lid p iid ik seed -> do-    coverSeed lid p iid seed-    coverKind lid p iid ik-  UpdDiscoverKind lid p iid ik -> discoverKind lid p iid ik-  UpdCoverKind lid p iid ik -> coverKind lid p iid ik-  UpdDiscoverSeed lid p iid seed -> discoverSeed lid p iid seed-  UpdCoverSeed lid p iid seed -> coverSeed lid p iid seed-  UpdPerception lid outPer inPer -> perception lid outPer inPer-  UpdRestart side sdisco sfper _ sdebugCli sgameMode -> do-    shistory <- getsClient shistory-    sreport <- getsClient sreport-    isAI <- getsClient sisAI-    let cli = defStateClient shistory sreport side isAI-    putClient cli { sdisco-                  , sfper-                  -- , sundo = [UpdAtomic cmd]-                  , scurDifficulty = sdifficultyCli sdebugCli-                  , sgameMode-                  , sdebugCli }-  UpdResume _fid sfper -> modifyClient $ \cli -> cli {sfper}-  UpdKillExit _fid -> killExit-  UpdSaveBkp -> saveClient-  _ -> return ()--createActor :: MonadClient m => ActorId -> Actor -> m ()-createActor aid _b = do-  let affect tgt = case tgt of-        TEnemyPos a _ _ permit | a == aid -> TEnemy a permit-        _ -> tgt-      affect3 (tgt, mpath) = case tgt of-        TEnemyPos a _ _ permit | a == aid -> (TEnemy a permit, Nothing)-        _ -> (tgt, mpath)-  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}--destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m ()-destroyActor aid b destroy = do-  when destroy $ modifyClient $ updateTarget aid (const Nothing)  -- gc-  modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}  -- gc-  let affect tgt = case tgt of-        TEnemy a permit | a == aid -> TEnemyPos a (blid b) (bpos b) permit-          -- Don't consider @destroy@, because even if actor dead, it makes-          -- sense to go to last known location to loot or find others.-        _ -> tgt-      affect3 (tgt, mpath) =-        let newMPath = case mpath of-              Just (_, (goal, _)) | goal /= bpos b -> Nothing-              _ -> mpath  -- foe slow enough, so old path good-        in (affect tgt, newMPath)-  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}--perception :: MonadClient m => LevelId -> Perception -> Perception -> m ()-perception lid outPer inPer = do-  -- Clients can't compute FOV on their own, because they don't know-  -- if unknown tiles are clear or not. Server would need to send-  -- info about properties of unknown tiles, which complicates-  -- and makes heavier the most bulky data set in the game: tile maps.-  -- Note we assume, but do not check that @outPer@ is contained-  -- in current perception and @inPer@ has no common part with it.-  -- It would make the already very costly operation even more expensive.-  perOld <- getPerFid lid-  -- Check if new perception is already set in @cmdAtomicFilterCli@-  -- or if we are doing undo/redo, which does not involve filtering.-  -- The data structure is strict, so the cheap check can't be any simpler.-  let interAlready per =-        Just $ totalVisible per `ES.intersection` totalVisible perOld-      unset = maybe False ES.null (interAlready inPer)-              || maybe False (not . ES.null) (interAlready outPer)-  when unset $ do-    let adj Nothing = assert `failure` "no perception to alter" `twith` lid-        adj (Just per) = Just $ addPer (diffPer per outPer) inPer-        f = EM.alter adj lid-    modifyClient $ \cli -> cli {sfper = f (sfper cli)}--discoverKind :: MonadClient m-             => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()-discoverKind lid p iid ik = do-  item <- getsState $ getItemBody iid-  let f Nothing = Just ik-      f Just{} = assert `failure` "already discovered"-                        `twith` (lid, p, iid, ik)-  modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}--coverKind :: MonadClient m-          => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()-coverKind lid p iid ik = do-  item <- getsState $ getItemBody iid-  let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)-      f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"-                                       `twith` (ik, ik2)) Nothing-  modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}--discoverSeed :: MonadClient m-             => LevelId -> Point -> ItemId -> ItemSeed -> m ()-discoverSeed lid p iid seed = do-  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops-  disco <- getsClient sdisco-  item <- getsState $ getItemBody iid-  Level{ldepth} <- getLevel (jlid item)-  totalDepth <- getsState stotalDepth-  case EM.lookup (jkindIx item) disco of-    Nothing -> assert `failure` "kind not known"-                      `twith` (lid, p, iid, seed)-    Just ik -> do-      let kind = okind ik-          f Nothing = Just $ seedToAspectsEffects seed kind ldepth totalDepth-          f Just{} = assert `failure` "already discovered"-                            `twith` (lid, p, iid, seed)-      modifyClient $ \cli -> cli {sdiscoAE = EM.alter f iid (sdiscoAE cli)}--coverSeed :: MonadClient m-          => LevelId -> Point -> ItemId -> ItemSeed -> m ()-coverSeed lid p iid ik = do-  let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)-      f Just{} = Nothing  -- checking that old and new agree is too much work-  modifyClient $ \cli -> cli {sdiscoAE = EM.alter f iid (sdiscoAE cli)}--killExit :: MonadClient m => m ()-killExit = modifyClient $ \cli -> cli {squit = True}
− Game/LambdaHack/Client/HandleResponseClient.hs 
@@ -1,63 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | Semantics of client commands.-module Game.LambdaHack.Client.HandleResponseClient-  ( handleResponseAI, handleResponseUI-  ) where--import Control.Exception.Assert.Sugar--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.AI-import Game.LambdaHack.Client.HandleAtomicClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.ProtocolClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response--storeUndo :: MonadClient m => CmdAtomic -> m ()-storeUndo _atomic =-  maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})-    $ Nothing   -- TODO: undoCmdAtomic atomic--handleResponseAI :: (MonadAtomic m, MonadClientWriteRequest RequestAI m)-                 => ResponseAI -> m ()-handleResponseAI cmd = case cmd of-  RespUpdAtomicAI cmdA -> do-    cmds <- cmdAtomicFilterCli cmdA-    mapM_ (\c -> cmdAtomicSemCli c-                 >> execUpdAtomic c) cmds-    mapM_ (storeUndo . UpdAtomic) cmds-  RespQueryAI aid -> do-    cmdC <- queryAI aid-    sendRequest cmdC-  RespPingAI -> do-    pong <- pongAI-    sendRequest pong--handleResponseUI :: ( MonadClientUI m-                    , MonadAtomic m-                    , MonadClientWriteRequest RequestUI m )-                 => ResponseUI -> m ()-handleResponseUI cmd = case cmd of-  RespUpdAtomicUI cmdA -> do-    cmds <- cmdAtomicFilterCli cmdA-    let handle c = do-          oldState <- getState-          oldStateClient <- getClient-          cmdAtomicSemCli c-          execUpdAtomic c-          displayRespUpdAtomicUI False oldState oldStateClient c-    mapM_ handle cmds-    mapM_ (storeUndo . UpdAtomic) cmds  -- TODO: only store cmdA?-  RespSfxAtomicUI sfx -> do-    displayRespSfxAtomicUI False sfx-    storeUndo $ SfxAtomic sfx-  RespQueryUI -> do-    cmdH <- queryUI-    sendRequest cmdH-  RespPingUI -> do-    pong <- pongUI-    sendRequest pong
− Game/LambdaHack/Client/ItemSlot.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Item slots for UI and AI item collections.--- TODO: document-module Game.LambdaHack.Client.ItemSlot-  ( ItemSlots, SlotChar(..)-  , allSlots, slotLabel, slotRange, assignSlot-  ) where--import Data.Binary-import Data.Char-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import qualified Data.IntMap.Strict as IM-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.State--newtype SlotChar = SlotChar {slotChar :: Char}-  deriving (Show, Eq, Binary)--instance Ord SlotChar where-  compare x y = compare (fromEnum x) (fromEnum y)--instance Enum SlotChar where-  fromEnum (SlotChar x) = fromEnum x + if isUpper x then 1000 else 0-  toEnum e = SlotChar $ toEnum $ e - (if e > 1000 then 1000 else 0)--type ItemSlots = (EM.EnumMap SlotChar ItemId, IM.IntMap ItemId)--slotRange :: [SlotChar] -> Text-slotRange ls =-  sectionBy (sort ls) Nothing- where-  succSlot c d = ord (slotChar d) - ord (slotChar c) == 1--  sectionBy []     Nothing       = T.empty-  sectionBy []     (Just (c, d)) = finish (c,d)-  sectionBy (x:xs) Nothing       = sectionBy xs (Just (x, x))-  sectionBy (x:xs) (Just (c, d))-    | succSlot d x               = sectionBy xs (Just (c, x))-    | otherwise                  = finish (c,d) <> sectionBy xs (Just (x, x))--  finish (c, d) | c == d         = T.pack [slotChar c]-                | succSlot c d   = T.pack [slotChar c, slotChar d]-                | otherwise      = T.pack [slotChar c, '-', slotChar d]--allSlots :: [SlotChar]-allSlots = map SlotChar $ ['a'..'z'] ++ ['A'..'Z']---- | Assigns a slot to an item, for inclusion in the inventory or equipment--- of a hero. Tries to to use the requested slot, if any.-assignSlot :: Item -> FactionId -> Maybe Actor -> ItemSlots -> SlotChar-           -> State-           -> Either SlotChar Int-assignSlot item fid mbody (letterSlots, numberSlots) lastSlot s =-  if jsymbol item == '$'-  then Left $ SlotChar '$'-  else case free of-    freeChar : _ -> Left freeChar-    [] -> Right $ head freeNumbers- where-  candidates = take (length allSlots)-               $ drop (1 + fromJust (elemIndex lastSlot allSlots))-               $ cycle allSlots-  onPerson = maybe (sharedAllOwnedFid fid s)-                   (\body -> sharedAllOwned body s)-                   mbody-  onGroud = maybe EM.empty-                  (\body -> sdungeon s EM.! blid body `atI` bpos body)-                  mbody-  inBags = ES.unions $ map EM.keysSet [onPerson, onGroud]-  f l = maybe True (`ES.notMember` inBags) $ EM.lookup l letterSlots-  free = filter f candidates-  g l = maybe True (`ES.notMember` inBags) $ IM.lookup l numberSlots-  freeNumbers = filter g [0..]--slotLabel :: Either SlotChar Int -> MU.Part-slotLabel (Left c) = MU.String [slotChar c]-slotLabel Right{} = "0"
− Game/LambdaHack/Client/Key.hs 
@@ -1,222 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Frontend-independent keyboard input operations.-module Game.LambdaHack.Client.Key-  ( Key(..), showKey, handleDir, dirAllKey-  , moveBinding, mkKM, keyTranslate-  , Modifier(..), KM(..), showKM-  , escKM, spaceKM, pgupKM, pgdnKM-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.Char as Char-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Generics (Generic)-import Prelude hiding (Left, Right)--import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Vector---- | Frontend-independent datatype to represent keys.-data Key =-    Esc-  | Return-  | Space-  | Tab-  | BackTab-  | BackSpace-  | PgUp-  | PgDn-  | Left-  | Right-  | Up-  | Down-  | End-  | Begin-  | Home-  | KP !Char      -- ^ a keypad key for a character (digits and operators)-  | Char !Char    -- ^ a single printable character-  | Unknown !Text -- ^ an unknown key, registered to warn the user-  deriving (Read, Ord, Eq, Generic)--instance Binary Key---- | Our own encoding of modifiers. Incomplete.-data Modifier =-    NoModifier-  | Control-  deriving (Read, Ord, Eq, Generic)--instance Binary Modifier--data KM = KM {modifier :: !Modifier, key :: !Key}-  deriving (Read, Ord, Eq, Generic)--instance Show KM where-  show = T.unpack . showKM--instance Binary KM---- Common and terse names for keys.-showKey :: Key -> Text-showKey (Char c) = T.singleton c-showKey Esc      = "ESC"-showKey Return   = "RET"-showKey Space    = "SPACE"-showKey Tab      = "TAB"-showKey BackTab  = "SHIFT-TAB"-showKey BackSpace = "BACKSPACE"-showKey Up       = "UP"-showKey Down     = "DOWN"-showKey Left     = "LEFT"-showKey Right    = "RIGHT"-showKey Home     = "HOME"-showKey End      = "END"-showKey PgUp     = "PGUP"-showKey PgDn     = "PGDOWN"-showKey Begin    = "BEGIN"-showKey (KP c)   = "KEYPAD_" <> T.singleton c-showKey (Unknown s) = s---- | Show a key with a modifier, if any.-showKM :: KM -> Text-showKM KM{modifier=Control, key} = "CTRL-" <> showKey key-showKM KM{modifier=NoModifier, key} = showKey key--escKM :: KM-escKM = KM {modifier = NoModifier, key = Esc}--spaceKM :: KM-spaceKM = KM {modifier = NoModifier, key = Space}--pgupKM :: KM-pgupKM = KM {modifier = NoModifier, key = PgUp}--pgdnKM :: KM-pgdnKM = KM {modifier = NoModifier, key = PgDn}--dirKeypadKey :: [Key]-dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]--dirKeypadShiftChar :: [Char]-dirKeypadShiftChar = ['7', '8', '9', '6', '3', '2', '1', '4']--dirKeypadShiftKey :: [Key]-dirKeypadShiftKey = map KP dirKeypadShiftChar--dirLaptopKey :: [Key]-dirLaptopKey = map Char ['7', '8', '9', 'o', 'l', 'k', 'j', 'u']--dirLaptopShiftKey :: [Key]-dirLaptopShiftKey = map Char ['&', '*', '(', 'O', 'L', 'K', 'J', 'U']--dirViChar :: [Char]-dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']--dirViKey :: [Key]-dirViKey = map Char dirViChar--dirViShiftKey :: [Key]-dirViShiftKey = map (Char . Char.toUpper) dirViChar--dirAllKey :: Bool -> Bool -> [Key]-dirAllKey configVi configLaptop = dirKeypadKey ++ if configVi-                                                  then dirViKey-                                                  else if configLaptop-                                                       then dirLaptopKey-                                                       else []---- | Configurable event handler for the direction keys.--- Used for directed commands such as close door.-handleDir :: Bool -> Bool -> KM -> (Vector -> a) -> a -> a-handleDir configVi configLaptop KM{modifier=NoModifier, key} h k =-  let assocs = zip (dirAllKey configVi configLaptop) $ moves ++ moves-  in maybe k h (lookup key assocs)-handleDir _ _ _ _ k = k---- | Binding of both sets of movement keys.-moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a)-            -> [(KM, a)]-moveBinding configVi configLaptop move run =-  let assign f (km, dir) = (km, f dir)-      mapMove modifier keys =-        map (assign move) (zip (zipWith KM (repeat modifier) keys) moves)-      mapRun modifier keys =-        map (assign run) (zip (zipWith KM (repeat modifier) keys) moves)-      dirOtherKey | configVi = dirViKey-                  | configLaptop = dirLaptopKey-                  | otherwise = []-      dirOtherShiftKey | configVi = dirViShiftKey-                       | configLaptop = dirLaptopShiftKey-                       | otherwise = []-  in mapMove NoModifier dirKeypadKey-     ++ mapMove NoModifier dirOtherKey-     ++ mapRun NoModifier dirKeypadShiftKey-     ++ mapRun NoModifier dirOtherShiftKey-     ++ mapRun Control dirKeypadKey-     ++ mapRun Control dirKeypadShiftKey-     ++ mapRun Control (map Char dirKeypadShiftChar)--mkKM :: String -> KM-mkKM s = let mkKey sk =-               case keyTranslate sk of-                 Unknown _ ->-                   assert `failure` "unknown key" `twith` s-                 key -> key-         in case s of-           ('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control}-           _ -> KM {key=mkKey s, modifier=NoModifier}---- | Translate key from a GTK string description to our internal key type.--- To be used, in particular, for the command bindings and macros--- in the config file.-keyTranslate :: String -> Key-keyTranslate "less"          = Char '<'-keyTranslate "greater"       = Char '>'-keyTranslate "period"        = Char '.'-keyTranslate "colon"         = Char ':'-keyTranslate "semicolon"     = Char ';'-keyTranslate "comma"         = Char ','-keyTranslate "question"      = Char '?'-keyTranslate "dollar"        = Char '$'-keyTranslate "parenleft"     = Char '('-keyTranslate "parenright"    = Char ')'-keyTranslate "asterisk"      = Char '*'-keyTranslate "KP_Multiply"   = KP '*'-keyTranslate "slash"         = Char '/'-keyTranslate "KP_Divide"     = Char '/'-keyTranslate "backslash"     = Char '\\'-keyTranslate "underscore"    = Char '_'-keyTranslate "minus"         = Char '-'-keyTranslate "KP_Subtract"   = Char '-'-keyTranslate "plus"          = Char '+'-keyTranslate "KP_Add"        = Char '+'-keyTranslate "equal"         = Char '='-keyTranslate "bracketleft"   = Char '['-keyTranslate "bracketright"  = Char ']'-keyTranslate "braceleft"     = Char '{'-keyTranslate "braceright"    = Char '}'-keyTranslate "ampersand"     = Char '&'-keyTranslate "apostrophe"    = Char '\''-keyTranslate "Escape"        = Esc-keyTranslate "Return"        = Return-keyTranslate "space"         = Space-keyTranslate "Tab"           = Tab-keyTranslate "ISO_Left_Tab"  = BackTab-keyTranslate "BackSpace"     = BackSpace-keyTranslate "KP_Up"         = Up-keyTranslate "KP_Down"       = Down-keyTranslate "KP_Left"       = Left-keyTranslate "KP_Right"      = Right-keyTranslate "KP_Home"       = Home-keyTranslate "KP_End"        = End-keyTranslate "Page_Up"       = PgUp-keyTranslate "KP_Page_Up"    = PgUp-keyTranslate "Page_Down"     = PgDn-keyTranslate "KP_Page_Down"  = PgDn-keyTranslate "KP_Begin"      = Begin-keyTranslate "KP_Enter"      = Return-keyTranslate ['K','P','_',c] = KP c-keyTranslate [c]             = Char c-keyTranslate s               = Unknown $ T.pack s
− Game/LambdaHack/Client/LoopClient.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | The main loop of the client, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Client.LoopClient (loopAI, loopUI) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.Text as T--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.HandleResponseClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.ProtocolClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind--initCli :: MonadClient m => DebugModeCli -> (State -> m ()) -> m Bool-initCli sdebugCli putSt = do-  -- Warning: state and client state are invalid here, e.g., sdungeon-  -- and sper are empty.-  cops <- getsState scops-  modifyClient $ \cli -> cli {sdebugCli}-  restored <- restoreGame-  case restored of-    Just (s, cli) | not $ snewGameCli sdebugCli -> do  -- Restore the game.-      let sCops = updateCOps (const cops) s-      putSt sCops-      putClient cli {sdebugCli}-      return True-    _ -> do  -- First visit ever, use the initial state.-      -- But preserve the previous history, if any (--newGame).-      case restored of-        Just (_, cliR) -> modifyClient $ \cli -> cli {shistory = shistory cliR}-        Nothing -> return ()-      return False--loopAI :: ( MonadAtomic m-          , MonadClientReadResponse ResponseAI m-          , MonadClientWriteRequest RequestAI m )-       => DebugModeCli -> m ()-loopAI sdebugCli = do-  side <- getsClient sside-  restored <- initCli sdebugCli-              $ \s -> handleResponseAI $ RespUpdAtomicAI $ UpdResumeServer s-  cmd1 <- receiveResponse-  case (restored, cmd1) of-    (True, RespUpdAtomicAI UpdResume{}) -> return ()-    (True, RespUpdAtomicAI UpdRestart{}) -> return ()-    (False, RespUpdAtomicAI UpdResume{}) -> do-      removeServerSave-      error $ T.unpack $-        "Savefile of client" <+> tshow side-        <+> "not usable. Removing server savefile. Please restart now."-    (False, RespUpdAtomicAI UpdRestart{}) -> return ()-    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)-  handleResponseAI cmd1-  -- State and client state now valid.-  debugPrint $ "AI client" <+> tshow side <+> "started."-  loop-  debugPrint $ "AI client" <+> tshow side <+> "stopped."- where-  loop = do-    cmd <- receiveResponse-    handleResponseAI cmd-    quit <- getsClient squit-    unless quit loop--loopUI :: ( MonadClientUI m-          , MonadAtomic m-          , MonadClientReadResponse ResponseUI m-          , MonadClientWriteRequest RequestUI m )-       => DebugModeCli -> m ()-loopUI sdebugCli = do-  Kind.COps{corule} <- getsState scops-  let title = rtitle $ Kind.stdRuleset corule-  side <- getsClient sside-  restored <- initCli sdebugCli-              $ \s -> handleResponseUI $ RespUpdAtomicUI $ UpdResumeServer s-  cmd1 <- receiveResponse-  case (restored, cmd1) of-    (True, RespUpdAtomicUI UpdResume{}) -> do-      mode <- getModeClient-      msgAdd $ mdesc mode-      handleResponseUI cmd1-    (True, RespUpdAtomicUI UpdRestart{}) -> do-      msgAdd $-        "Ignoring an old savefile and starting a new" <+> title <+> "game."-      handleResponseUI cmd1-    (False, RespUpdAtomicUI UpdResume{}) -> do-      removeServerSave-      error $ T.unpack $-        "Savefile of client" <+> tshow side-        <+> "not usable. Removing server savefile. Please restart now."-    (False, RespUpdAtomicUI UpdRestart{}) -> do-      msgAdd $ "Welcome to" <+> title <> "!"-      handleResponseUI cmd1-    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)-  fact <- getsState $ (EM.! side) . sfactionD-  when (playerAI $ gplayer fact) $-    -- Prod the frontend to flush frames and start showing then continuously.-    void $ displayMore ColorFull "The team is under AI control (ESC to stop)."-  -- State and client state now valid.-  debugPrint $ "UI client" <+> tshow side <+> "started."-  loop-  debugPrint $ "UI client" <+> tshow side <+> "stopped."- where-  loop = do-    cmd <- receiveResponse-    handleResponseUI cmd-    quit <- getsClient squit-    unless quit loop
− Game/LambdaHack/Client/MonadClient.hs 
@@ -1,95 +0,0 @@--- | Basic client monad and related operations.-module Game.LambdaHack.Client.MonadClient-  ( -- * Basic client monad-    MonadClient( getClient, getsClient, modifyClient, putClient-               , saveChanClient  -- exposed only to be implemented, not used-               , liftIO  -- exposed only to be implemented, not used-               )-    -- * Assorted primitives-  , debugPrint, saveClient, saveName, restoreGame, removeServerSave, rndToAction-  ) where--import Control.Monad-import qualified Control.Monad.State as St-import Data.Maybe-import Data.Text (Text)-import System.Directory-import System.FilePath--import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.File-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Random-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.RuleKind--class MonadStateRead 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-  saveChanClient :: m (Save.ChanSave (State, StateClient))--debugPrint :: MonadClient m => Text -> m ()-debugPrint t = do-  sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli-  when sdbgMsgCli $ liftIO $ Save.delayPrint t--saveClient :: MonadClient m => m ()-saveClient = do-  s <- getState-  cli <- getClient-  toSave <- saveChanClient-  liftIO $ Save.saveToChan toSave (s, cli)--saveName :: FactionId -> Bool -> String-saveName side isAI =-  let n = fromEnum side  -- we depend on the numbering hack to number saves-  in (if n > 0-      then "human_" ++ show n-      else "computer_" ++ show (-n))-     ++ if isAI then ".ai.sav" else ".ui.sav"--restoreGame :: MonadClient m => m (Maybe (State, StateClient))-restoreGame = do-  Kind.COps{corule} <- getsState scops-  let stdRuleset = Kind.stdRuleset corule-      pathsDataFile = rpathsDataFile stdRuleset-      cfgUIName = rcfgUIName stdRuleset-  side <- getsClient sside-  isAI <- getsClient sisAI-  prefix <- getsClient $ ssavePrefixCli . sdebugCli-  let copies = [( "GameDefinition" </> cfgUIName <.> "default"-                , cfgUIName <.> "ini" )]-      name = fromMaybe "save" prefix <.> saveName side isAI-  liftIO $ Save.restoreGame name copies pathsDataFile---- | Assuming the client runs on the same machine and for the same--- user as the server, move the server savegame out of the way.-removeServerSave :: MonadClient m => m ()-removeServerSave = do-  -- Hack: assume the same prefix for client as for the server.-  prefix <- getsClient $ ssavePrefixCli . sdebugCli-  dataDir <- liftIO appDataDir-  let serverSaveFile = dataDir-                       </> "saves"-                       </> fromMaybe "save" prefix-                       <.> serverSaveName-  bSer <- liftIO $ doesFileExist serverSaveFile-  when bSer $ liftIO $ renameFile serverSaveFile (serverSaveFile <.> "bkp")---- | Invoke pseudo-random computation with the generator kept in the state.-rndToAction :: MonadClient m => Rnd a -> m a-rndToAction r = do-  g <- getsClient srandom-  let (a, ng) = St.runState r g-  modifyClient $ \cli -> cli {srandom = ng}-  return a
− Game/LambdaHack/Client/ProtocolClient.hs 
@@ -1,14 +0,0 @@-{-# LANGUAGE FlexibleContexts, FunctionalDependencies, RankNTypes, TupleSections-             #-}--- | The client-server communication monads.-module Game.LambdaHack.Client.ProtocolClient-  ( MonadClientReadResponse(..), MonadClientWriteRequest(..)-  ) where--import Game.LambdaHack.Client.MonadClient--class MonadClient m => MonadClientReadResponse resp m | m -> resp where-  receiveResponse  :: m resp--class MonadClient m => MonadClientWriteRequest req m | m -> req where-  sendRequest  :: req -> m ()
− Game/LambdaHack/Client/State.hs 
@@ -1,293 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Server and client game state types and operations.-module Game.LambdaHack.Client.State-  ( StateClient(..), defStateClient, defaultHistory-  , updateTarget, getTarget, updateLeader, sside-  , PathEtc, TgtMode(..), Target(..), RunParams(..), LastRecord-  , toggleMarkVision, toggleMarkSmell, toggleMarkSuspect-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import qualified Data.IntMap.Strict as IM-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU-import qualified System.Random as R-import System.Time--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.ItemSlot-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector---- | Client state, belonging to a single faction.--- Some of the data, e.g, the history, carries over--- from game to game, even across playing sessions.--- Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@.-data StateClient = StateClient-  { stgtMode     :: !(Maybe TgtMode)-                                   -- ^ targeting mode-  , scursor      :: !Target        -- ^ the common, cursor target-  , seps         :: !Int           -- ^ a parameter of the tgt digital line-  , stargetD     :: !(EM.EnumMap ActorId (Target, Maybe PathEtc))-                                   -- ^ targets of our actors in the dungeon-  , sexplored    :: !(ES.EnumSet LevelId)-                                   -- ^ the set of fully explored levels-  , sbfsD        :: !(EM.EnumMap ActorId-                        ( PointArray.Array BfsDistance-                        , Point, Int, Maybe [Point]) )-                                   -- ^ pathfinding distances for our actors-                                   --   and paths to their targets, if any-  , sselected    :: !(ES.EnumSet ActorId)-                                   -- ^ the set of currently selected actors-  , srunning     :: !(Maybe RunParams)-                                   -- ^ parameters of the current run, if any-  , sreport      :: !Report        -- ^ current messages-  , shistory     :: !History       -- ^ history of messages-  , sdisplayed   :: !(EM.EnumMap LevelId Time)-                                   -- ^ moves are displayed up to this time-  , sundo        :: ![CmdAtomic]   -- ^ atomic commands performed to date-  , sdisco       :: !Discovery     -- ^ remembered item discoveries-  , sdiscoAE     :: !DiscoAE       -- ^ remembered aspects and effects of items-  , sfper        :: !FactionPers   -- ^ faction perception indexed by levels-  , srandom      :: !R.StdGen      -- ^ current random generator-  , slastRecord  :: !LastRecord    -- ^ state of key sequence recording-  , slastPlay    :: ![K.KM]        -- ^ state of key sequence playback-  , swaitTimes   :: !Int           -- ^ player just waited this many times-  , _sleader     :: !(Maybe ActorId)-                                   -- ^ current picked party leader-  , _sside       :: !FactionId     -- ^ faction controlled by the client-  , squit        :: !Bool          -- ^ exit the game loop-  , sisAI        :: !Bool          -- ^ whether it's an AI client-  , smarkVision  :: !Bool          -- ^ mark leader and party FOV-  , smarkSmell   :: !Bool          -- ^ mark smell, if the leader can smell-  , smarkSuspect :: !Bool          -- ^ mark suspect features-  , scurDifficulty :: !Int         -- ^ current game difficulty level-  , sslots       :: !ItemSlots     -- ^ map from slots to items-  , slastSlot    :: !SlotChar      -- ^ last used slot-  , sgameMode    :: !Text          -- ^ current game mode-  , sdebugCli    :: !DebugModeCli  -- ^ client debugging mode-  }-  deriving Show--type PathEtc = ([Point], (Point, Int))---- | Current targeting mode of a client.-newtype TgtMode = TgtMode { tgtLevelId :: LevelId }-  deriving (Show, Eq, Binary)---- | The type of na actor target.-data Target =-    TEnemy !ActorId !Bool-    -- ^ target an actor; cycle only trough seen foes, unless the flag is set-  | TEnemyPos !ActorId !LevelId !Point !Bool-    -- ^ last seen position of the targeted actor-  | TPoint !LevelId !Point              -- ^ target a concrete spot-  | TVector !Vector                     -- ^ target position relative to actor-  deriving (Show, Eq)---- | Parameters of the current run.-data RunParams = RunParams-  { runLeader  :: !ActorId         -- ^ the original leader from run start-  , runMembers :: ![ActorId]       -- ^ the list of actors that take part-  , runDist    :: !Int             -- ^ distance of the run so far-                                   --   (plus one, if multiple runners)-  , runStopMsg :: !(Maybe Text)    -- ^ message with the next stop reason-  , runInitDir :: !(Maybe Vector)  -- ^ the direction of the initial step-  }-  deriving (Show)--type LastRecord = ( [K.KM]  -- accumulated keys of the current command-                  , [K.KM]  -- keys of the rest of the recorded command batch-                  , Int     -- commands left to record for this batch-                  )---- | Initial game client state.-defStateClient :: History -> Report -> FactionId -> Bool -> StateClient-defStateClient shistory sreport _sside sisAI =-  StateClient-    { stgtMode = Nothing-    , scursor = if sisAI-                then TVector $ Vector 30000 30000  -- invalid-                else TVector $ Vector 1 1  -- a step south-east-    , seps = fromEnum _sside-    , stargetD = EM.empty-    , sexplored = ES.empty-    , sbfsD = EM.empty-    , sselected = ES.empty-    , srunning = Nothing-    , sreport-    , shistory-    , sdisplayed = EM.empty-    , sundo = []-    , sdisco = EM.empty-    , sdiscoAE = EM.empty-    , sfper = EM.empty-    , srandom = R.mkStdGen 42  -- will be set later-    , slastRecord = ([], [], 0)-    , slastPlay = []-    , swaitTimes = 0-    , _sleader = Nothing  -- no heroes yet alive-    , _sside-    , squit = False-    , sisAI-    , smarkVision = False-    , smarkSmell = True-    , smarkSuspect = False-    , scurDifficulty = difficultyDefault-    , sslots = (EM.empty, IM.empty)-    , slastSlot = SlotChar 'a'-    , sgameMode = "campaign"-    , sdebugCli = defDebugModeCli-    }--defaultHistory :: IO History-defaultHistory = do-  dateTime <- getClockTime-  let curDate = MU.Text $ T.pack $ calendarTimeToString $ toUTCTime dateTime-  return $! singletonHistory $ singletonReport-         $! makeSentence ["Human history log started on", curDate]---- | Update target parameters within client state.-updateTarget :: ActorId -> (Maybe Target -> Maybe Target) -> StateClient-             -> StateClient-updateTarget aid f cli =-  let f2 tp = case f $ fmap fst tp of-        Nothing -> Nothing-        Just tgt -> Just (tgt, Nothing)  -- reset path-  in cli {stargetD = EM.alter f2 aid (stargetD cli)}---- | Get target parameters from client state.-getTarget :: ActorId -> StateClient -> Maybe Target-getTarget aid cli = fmap fst $ EM.lookup aid $ stargetD cli---- | Update picked leader within state. Verify actor's faction.-updateLeader :: ActorId -> State -> StateClient -> StateClient-updateLeader leader s cli =-  let side1 = bfid $ getActorBody leader s-      side2 = sside cli-  in assert (side1 == side2 `blame` "enemy actor becomes our leader"-                            `twith` (side1, side2, leader, s))-     $ cli {_sleader = Just leader}--sside :: StateClient -> FactionId-sside = _sside--toggleMarkVision :: StateClient -> StateClient-toggleMarkVision s@StateClient{smarkVision} = s {smarkVision = not smarkVision}--toggleMarkSmell :: StateClient -> StateClient-toggleMarkSmell s@StateClient{smarkSmell} = s {smarkSmell = not smarkSmell}--toggleMarkSuspect :: StateClient -> StateClient-toggleMarkSuspect s@StateClient{smarkSuspect} =-  s {smarkSuspect = not smarkSuspect}--instance Binary StateClient where-  put StateClient{..} = do-    put stgtMode-    put scursor-    put seps-    put stargetD-    put sexplored-    put sselected-    put srunning-    put sreport-    put shistory-    put sundo-    put sdisplayed-    put sdisco-    put sdiscoAE-    put (show srandom)-    put _sleader-    put _sside-    put sisAI-    put smarkVision-    put smarkSmell-    put smarkSuspect-    put scurDifficulty-    put sslots-    put slastSlot-    put sgameMode-    put sdebugCli  -- TODO: this is overwritten at once-  get = do-    stgtMode <- get-    scursor <- get-    seps <- get-    stargetD <- get-    sexplored <- get-    sselected <- get-    srunning <- get-    sreport <- get-    shistory <- get-    sundo <- get-    sdisplayed <- get-    sdisco <- get-    sdiscoAE <- get-    g <- get-    _sleader <- get-    _sside <- get-    sisAI <- get-    smarkVision <- get-    smarkSmell <- get-    smarkSuspect <- get-    scurDifficulty <- get-    sslots <- get-    slastSlot <- get-    sgameMode <- get-    sdebugCli <- get-    let sbfsD = EM.empty-        sfper = EM.empty-        srandom = read g-        slastRecord = ([], [], 0)-        slastPlay = []-        swaitTimes = 0-        squit = False-    return $! StateClient{..}--instance Binary RunParams where-  put RunParams{..} = do-    put runLeader-    put runMembers-    put runDist-    put runStopMsg-    put runInitDir-  get = do-    runLeader <- get-    runMembers <- get-    runDist<- get-    runStopMsg <- get-    runInitDir <- get-    return $! RunParams{..}--instance Binary Target where-  put (TEnemy a permit) = putWord8 0 >> put a >> put permit-  put (TEnemyPos a lid p permit) =-    putWord8 1 >> put a >> put lid >> put p >> put permit-  put (TPoint lid p) = putWord8 2 >> put lid >> put p-  put (TVector v) = putWord8 3 >> put v-  get = do-    tag <- getWord8-    case tag of-      0 -> liftM2 TEnemy get get-      1 -> liftM4 TEnemyPos get get get get-      2 -> liftM2 TPoint get get-      3 -> liftM TVector get-      _ -> fail "no parse (Target)"
− Game/LambdaHack/Client/UI.hs 
@@ -1,177 +0,0 @@--- | Ways for the client to use player input via UI to produce server--- requests, based on the client's view (visualized for the player)--- of the game state.-module Game.LambdaHack.Client.UI-  ( -- * Client UI monad-    MonadClientUI-    -- * Assorted UI operations-  , queryUI, pongUI-  , displayRespUpdAtomicUI, displayRespSfxAtomicUI-    -- * Startup-  , srtFrontend, KeyKind, SessionUI-    -- * Operations exposed for LoopClient-  , ColorMode(..), displayMore, msgAdd-    -- * Internal functions-  , humanCommand-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.Map.Strict as M-import Data.Maybe--import Game.LambdaHack.Atomic-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.DisplayAtomicClient-import Game.LambdaHack.Client.UI.HandleHumanClient-import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.RunClient-import Game.LambdaHack.Client.UI.StartupFrontendClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind---- | Handle the move of a UI player.-queryUI :: MonadClientUI m => m RequestUI-queryUI = do-  cops <- getsState scops-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  let leader = fromMaybe (assert `failure` fact) $ gleader fact-  srunning <- getsClient srunning-  -- When running, stop if disturbed. If not running, let the human-  -- player issue commands, until any command takes time.-  req <- case srunning of-    Nothing -> humanCommand Nothing-    Just RunParams{runMembers}-      | isAllMoveFact cops fact && runMembers /= [leader] -> do-      stopRunning-      Config{configRunStopMsgs} <- askConfig-      let msg = if configRunStopMsgs-                then Just $ "Run stop: all-mover leader change"-                else Nothing-      humanCommand msg-    Just runParams -> do-      runOutcome <- continueRun runParams-      case runOutcome of-        Left stopMsg -> do-          stopRunning-          Config{configRunStopMsgs} <- askConfig-          let msg = if configRunStopMsgs-                    then Just $ "Run stop:" <+> stopMsg-                    else Nothing-          humanCommand msg-        Right (paramNew, runCmd) -> do-          modifyClient $ \cli -> cli {srunning = Just paramNew}-          displayPush-          return $! anyToUI $ runCmd-  leader2 <- getLeaderUI-  if leader2 /= leader-    then return $! ReqUILeader leader2 req-    else return $! req---- | Determine and process the next human player command. The argument is--- the last stop message due to running, if any.-humanCommand :: forall m. MonadClientUI m-             => Maybe Msg -> m RequestUI-humanCommand msgRunStop = do-  -- For human UI we invalidate whole @sbfsD@ at the start of each-  -- UI player input, which is an overkill, but doesn't affects-  -- screensavers, because they are UI, but not human.-  modifyClient $ \cli -> cli {sbfsD = EM.empty}-  let loop :: Maybe (Bool, Overlay) -> m RequestUI-      loop mover = do-        (lastBlank, over) <- case mover of-          Nothing -> do-            -- Display current state if no slideshow or if interrupted.-            sli <- promptToSlideshow ""-            return (False, head . snd $! slideshow sli)-          Just bLast ->-            -- (Re-)display the last slide while waiting for the next key.-            return bLast-        (seqCurrent, seqPrevious, k) <- getsClient slastRecord-        case k of-          0 -> do-            let slastRecord = ([], seqCurrent, 0)-            modifyClient $ \cli -> cli {slastRecord}-          _ -> do-            let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1)-            modifyClient $ \cli -> cli {slastRecord}-        km <- getKeyOverlayCommand lastBlank over-        -- Messages shown, so update history and reset current report.-        recordHistory-        abortOrCmd <- do-          -- Look up the key.-          Binding{bcmdMap} <- askBinding-          case M.lookup km bcmdMap of-            Just (_, _, cmd) -> do-              -- Query and clear the last command key.-              stgtMode <- getsClient stgtMode-              modifyClient $ \cli -> cli-                {swaitTimes = if swaitTimes cli > 0-                              then - swaitTimes cli-                              else 0}-              if km == K.escKM && isNothing stgtMode && isJust mover-                then cmdHumanSem Clear-                else cmdHumanSem cmd-            Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"-                       in fmap Left $ promptToSlideshow msgKey-        -- The command was failed or successful and if the latter,-        -- possibly took some time.-        case abortOrCmd of-          Right cmdS ->-            -- Exit the loop and let other actors act. No next key needed-            -- and no slides could have been generated.-            return cmdS-          Left slides -> do-            -- If no time taken, rinse and repeat.-            -- Analyse the obtained slides.-            let (onBlank, sli) = slideshow slides-            mLast <- case sli of-              [] -> return Nothing-              [sLast] ->-                -- Avoid displaying the single slide twice.-                return $ Just (onBlank, sLast)-              _ -> do-                -- Show, one by one, all slides, awaiting confirmation-                -- for all but the last one (which is displayed twice, BTW).-                -- Note: the code that generates the slides is responsible-                -- for inserting the @more@ prompt.-                go <- getInitConfirms ColorFull [km] slides-                return $! if go then Just (onBlank, last sli) else Nothing-            loop mLast-  case msgRunStop of-    Nothing -> loop Nothing-    Just msg -> do-      sli <- promptToSlideshow msg-      loop $ Just (False, head . snd $ slideshow sli)---- | Client signals to the server that it's still online, flushes frames--- (if needed) and sends some extra info.-pongUI :: MonadClientUI m => m RequestUI-pongUI = do-  escPressed <- tryTakeMVarSescMVar-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  let pong ats = return $ ReqUIPong ats-      underAI = playerAI $ gplayer fact-  if escPressed && underAI && playerLeader (gplayer fact) then do-    -- Ask server to turn off AI for the faction's leader.-    let atomicCmd = UpdAtomic $ UpdAutoFaction side False-    pong [atomicCmd]-  else do-    -- Respond to the server normally, perhaps pinging the frontend, too.-    when underAI syncFrames-    pong []
− Game/LambdaHack/Client/UI/Animation.hs 
@@ -1,217 +0,0 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}--- | Screen frames and animations.-module Game.LambdaHack.Client.UI.Animation-  ( SingleFrame(..), decodeLine, encodeLine-  , overlayOverlay-  , Animation, Frames, renderAnim, restrictAnim-  , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import Data.Bits-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Vector.Generic as G-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Color-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random--decodeLine :: ScreenLine -> [AttrChar]-decodeLine v = map (toEnum . fromIntegral) $ G.toList v---- | The data sufficent to draw a single game screen frame.-data SingleFrame = SingleFrame-  { sfLevel  :: ![ScreenLine]  -- ^ screen, from top to bottom, line by line-  , sfTop    :: !Overlay       -- ^ some extra lines to show over the top-  , sfBottom :: ![ScreenLine]  -- ^ some extra lines to show at the bottom-  , sfBlank  :: !Bool          -- ^ display only @sfTop@, on blank screen-  }-  deriving (Eq, Show, Generic)--instance Binary SingleFrame---- | Overlays the @sfTop@ and @sfBottom@ fields onto the @sfLevel@ field.--- The resulting frame has empty @sfTop@ and @sfBottom@.--- To be used by simple frontends that don't display overlays--- in separate windows/panes/scrolled views.-overlayOverlay :: SingleFrame -> SingleFrame-overlayOverlay SingleFrame{..} =-  let lxsize = fst normalLevelBound + 1  -- TODO-      lysize = snd normalLevelBound + 1-      emptyLine = encodeLine-                  $ replicate lxsize (Color.AttrChar Color.defAttr ' ')-      canvasLength = if sfBlank then lysize + 3 else lysize + 1-      canvas | sfBlank = replicate canvasLength emptyLine-             | otherwise = emptyLine : sfLevel-      topTrunc = overlay sfTop-      topLayer = if length topTrunc <= canvasLength-                 then topTrunc-                 else take (canvasLength - 1) topTrunc-                      ++ [toScreenLine "--a portion of the text trimmed--"]-      f layerLine canvasLine =-        layerLine G.++ G.drop (G.length layerLine) canvasLine-      picture = zipWith f topLayer canvas-      bottomLines = if sfBlank then [] else sfBottom-      newLevel = picture ++ drop (length picture) canvas ++ bottomLines-  in SingleFrame { sfLevel = newLevel-                 , sfTop = emptyOverlay-                 , sfBottom = []-                 , sfBlank }---- | Animation is a list of frame modifications to play one by one,--- where each modification if a map from positions to level map symbols.-newtype Animation = Animation [EM.EnumMap Point AttrChar]-  deriving (Eq, Show, Monoid)---- | Sequences of screen frames, including delays.-type Frames = [Maybe SingleFrame]---- | Render animations on top of a screen frame.-renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames-renderAnim lxsize lysize basicFrame (Animation anim) =-  let modifyFrame SingleFrame{sfLevel = []} _ =-        assert `failure` (lxsize, lysize, basicFrame, anim)-      modifyFrame SingleFrame{sfLevel = levelOld, ..} am =-        let fLine y lineOld =-              let f l (x, acOld) =-                    let pos = Point x y-                        !ac = fromMaybe acOld $ EM.lookup pos am-                    in ac : l-              in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))-            sfLevel =  -- fully evaluated inside-              let f l (y, lineOld) = let !line = fLine y lineOld in line : l-              in map encodeLine-                 $ foldl' f [] (zip [lysize-1,lysize-2..0]-                                $ reverse $ map decodeLine levelOld)-        in Just SingleFrame{..}  -- a thunk within Just-  in Nothing : map (modifyFrame basicFrame) anim ++ [Nothing]--blank :: Maybe AttrChar-blank = Nothing--coloredSymbol :: Color -> Char -> Maybe AttrChar-coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol--mzipPairs :: (Point, Point) -> (Maybe AttrChar, Maybe AttrChar)-          -> [(Point, AttrChar)]-mzipPairs (p1, p2) (mattr1, mattr2) =-  let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr-  in catMaybes $ if p1 /= p2-                 then [mzip (p1, mattr1), mzip (p2, mattr2)]-                 else -- If actor affects himself, show only the effect,-                      -- not the action.-                      [mzip (p1, mattr1)]--restrictAnim :: ES.EnumSet Point -> Animation -> Animation-restrictAnim vis (Animation as) =-  let f imap =-        let common = EM.intersection imap $ EM.fromSet (const ()) vis-          in if EM.null common then Nothing else Just common-  in Animation $ mapMaybe f as---- | Attack animation. A part of it also reused for self-damage and healing.-twirlSplash :: (Point, Point) -> Color -> Color -> Animation-twirlSplash poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)-  [ (blank                    , coloredSymbol BrCyan '\'')-  , (blank                    , coloredSymbol BrYellow '^')-  , (coloredSymbol c1      '/', coloredSymbol BrCyan '^')-  , (coloredSymbol c1      '-', blank)-  , (coloredSymbol c1      '\\',blank)-  , (coloredSymbol c1      '|', blank)-  , (coloredSymbol c2      '%', blank)-  , (coloredSymbol c2      '/', blank)-  ]---- | Attack that hits through a block.-blockHit :: (Point, Point) -> Color -> Color -> Animation-blockHit poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)-  [ (blank                    , coloredSymbol BrCyan '\'')-  , (blank                    , coloredSymbol BrYellow '^')-  , (blank                    , coloredSymbol BrCyan '^')-  , (coloredSymbol BrBlue  '{', coloredSymbol BrYellow '\'')-  , (coloredSymbol BrBlue  '{', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol c1      '\\',blank)-  , (coloredSymbol c1      '|', blank)-  , (coloredSymbol c2      '%', blank)-  , (coloredSymbol c2      '/', blank)-  ]---- | Attack that is blocked.-blockMiss :: (Point, Point) -> Animation-blockMiss poss = Animation $ map (EM.fromList . mzipPairs poss)-  [ (blank                    , coloredSymbol BrCyan '\'')-  , (coloredSymbol BrBlue  '{', coloredSymbol BrYellow '^')-  , (coloredSymbol BrBlue  '{', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol Blue    '}', blank)-  ]---- | Death animation for an organic body.-deathBody :: Point -> Animation-deathBody pos = Animation $ map (maybe EM.empty (EM.singleton pos))-  [ coloredSymbol BrRed '\\'-  , coloredSymbol BrRed '\\'-  , coloredSymbol BrRed '|'-  , coloredSymbol BrRed '|'-  , coloredSymbol BrRed '%'-  , coloredSymbol BrRed '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   ';'-  , coloredSymbol Red   ';'-  , coloredSymbol Red   ','-  ]---- | Swap-places animation, both hostile and friendly.-swapPlaces :: (Point, Point) -> Animation-swapPlaces poss = Animation $ map (EM.fromList . mzipPairs poss)-  [ (coloredSymbol BrMagenta 'o', coloredSymbol Magenta   'o')-  , (coloredSymbol BrMagenta 'd', coloredSymbol Magenta   'p')-  , (coloredSymbol Magenta   'p', coloredSymbol BrMagenta 'd')-  , (coloredSymbol Magenta   'o', blank)-  ]--fadeout :: Bool -> Bool -> Int -> X -> Y -> Rnd Animation-fadeout out topRight step lxsize lysize = do-  let xbound = lxsize - 1-      ybound = lysize - 1-      edge = EM.fromDistinctAscList $ zip [1..] ".%&%;:,."-      fadeChar r n x y =-        let d = x - 2 * y-            ndy = n - d - 2 * ybound-            ndx = n + d - xbound - 1  -- @-1@ for asymmetry-            mnx = if ndy > 0 && ndx > 0-                  then min ndy ndx-                  else max ndy ndx-            v3 = (r `xor` (x * y)) `mod` 3-            k | mnx < 3 || mnx > 10 = mnx-              | (min x (xbound - x - y) + n + v3) `mod` 15 < 11-                && mnx > 6 = mnx - v3-              | (x + 3 * y + v3) `mod` 30 < 19 = mnx + 1-              | otherwise = mnx-        in EM.findWithDefault ' ' k edge-      rollFrame n = do-        r <- random-        let l = [ ( Point (if topRight then x else xbound - x) y-                  , AttrChar defAttr $ fadeChar r n x y )-                | x <- [0..xbound]-                , y <- [max 0 (ybound - (n - x) `div` 2)..ybound]-                    ++ [0..min ybound ((n - xbound + x) `div` 2)]-                ]-        return $! EM.fromList l-      startN = if out then 3 else 1-      fs = [startN, startN + step .. 3 * lxsize `divUp` 4 + 2]-  as <- mapM rollFrame $ if out then fs else reverse fs-  return $! Animation as
− Game/LambdaHack/Client/UI/Config.hs 
@@ -1,120 +0,0 @@--- | Personal game configuration file type definitions.-module Game.LambdaHack.Client.UI.Config-  ( Config(..), mkConfig, applyConfigToDebug-  ) where--import Control.DeepSeq-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.Ini as Ini-import qualified Data.Ini.Reader as Ini-import qualified Data.Ini.Types as Ini-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Game.LambdaHack.Common.ClientOptions-import System.Directory-import System.FilePath-import Text.Read--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Common.File-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Content.RuleKind---- | Fully typed contents of the UI config file. This config--- is a part of a game client.-data Config = Config-  { -- commands-    configCommands    :: ![(K.KM, ([CmdCategory], HumanCmd))]-    -- hero names-  , configHeroNames   :: ![(Int, (Text, Text))]-    -- ui-  , configVi          :: !Bool  -- ^ the option for Vi keys takes precendence-  , configLaptop      :: !Bool  -- ^ because the laptop keys are the default-  , configFont        :: !String-  , configHistoryMax  :: !Int-  , configMaxFps      :: !Int-  , configNoAnim      :: !Bool-  , configRunStopMsgs :: !Bool-  }-  deriving Show--instance NFData Config--parseConfig :: Ini.Config -> Config-parseConfig cfg =-  let configCommands =-        let mkCommand (ident, keydef) =-              case stripPrefix "Macro_" ident of-                Just _ ->-                  let (key, def) = read keydef-                  in (K.mkKM key, def :: ([CmdCategory], HumanCmd))-                Nothing -> assert `failure` "wrong macro id" `twith` ident-            section = Ini.allItems "extra_commands" cfg-        in map mkCommand section-      configHeroNames =-        let toNumber (ident, nameAndPronoun) =-              case stripPrefix "HeroName_" ident of-                Just n -> (read n, read nameAndPronoun)-                Nothing -> assert `failure` "wrong hero name id" `twith` ident-            section = Ini.allItems "hero_names" cfg-        in map toNumber section-      getOption :: forall a. Read a => String -> a-      getOption optionName =-        let lookupFail :: forall b. String -> b-            lookupFail err =-              assert `failure` ("config file access failed:" <+> T.pack err)-                     `twith` (optionName, cfg)-            s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg-        in either lookupFail id $ readEither s-      configVi = getOption "movementViKeys_hjklyubn"-      -- The option for Vi keys takes precendence,-      -- because the laptop keys are the default.-      configLaptop = not configVi && getOption "movementLaptopKeys_uk8o79jl"-      configFont = getOption "font"-      configHistoryMax = getOption "historyMax"-      configMaxFps = max 1 $ getOption "maxFps"-      configNoAnim = getOption "noAnim"-      configRunStopMsgs = getOption "runStopMsgs"-  in Config{..}---- | Read and parse UI config file.-mkConfig :: Kind.Ops RuleKind -> IO Config-mkConfig corule = do-  let stdRuleset = Kind.stdRuleset corule-      cfgUIName = rcfgUIName stdRuleset-      commentsUIDefault = init $ map (drop 2) $ lines $ rcfgUIDefault stdRuleset  -- TODO: init is a hack until Ini accepts empty files-      sUIDefault = unlines commentsUIDefault-      cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault-  dataDir <- appDataDir-  let userPath = dataDir </> cfgUIName <.> "ini"-  cfgUser <- do-    cpExists <- doesFileExist userPath-    if not cpExists-      then return Ini.emptyConfig-      else do-        sUser <- readFile userPath-        return $! either (assert `failure`) id $ Ini.parse sUser-  let cfgUI = M.unionWith M.union cfgUser cfgUIDefault  -- user cfg preferred-      conf = parseConfig cfgUI-  -- Catch syntax errors in complex expressions ASAP,-  return $! deepseq conf conf--applyConfigToDebug :: Config -> DebugModeCli -> Kind.Ops RuleKind-                   -> DebugModeCli-applyConfigToDebug sconfig sdebugCli corule =-  let stdRuleset = Kind.stdRuleset corule-  in (\dbg -> dbg {sfont =-        sfont dbg `mplus` Just (configFont sconfig)}) .-     (\dbg -> dbg {smaxFps =-        smaxFps dbg `mplus` Just (configMaxFps sconfig)}) .-     (\dbg -> dbg {snoAnim =-        snoAnim dbg `mplus` Just (configNoAnim sconfig)}) .-     (\dbg -> dbg {ssavePrefixCli =-        ssavePrefixCli dbg `mplus` Just (rsavePrefix stdRuleset)})-     $ sdebugCli
− Game/LambdaHack/Client/UI/Content/KeyKind.hs 
@@ -1,13 +0,0 @@--- | The type of key-command mappings to be used for the UI.-module Game.LambdaHack.Client.UI.Content.KeyKind-  ( KeyKind(..)-  ) where--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.HumanCmd---- | Key-command mappings to be used for the UI.-data KeyKind = KeyKind-  { rhumanCommands :: ![(K.KM, ([CmdCategory], HumanCmd))]-                                   -- ^ default client UI commands-  }
− Game/LambdaHack/Client/UI/DisplayAtomicClient.hs 
@@ -1,701 +0,0 @@--- | Display atomic commands received by the client.-module Game.LambdaHack.Client.UI.DisplayAtomicClient-  ( displayRespUpdAtomicUI, displayRespSfxAtomicUI-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.IntMap.Strict as IM-import Data.Maybe-import Data.Monoid-import Data.Tuple-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.ItemSlot-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind---- * RespUpdAtomicUI---- TODO: let user configure which messages are not created, which are--- slightly hidden, which are shown and which flash and center screen--- and perhaps highligh the related location/actor. Perhaps even--- switch to the actor, changing HP displayed on screen, etc.--- but it's too short a clip to read the numbers, so probably--- highlighing should be enough.--- TODO: for a start, flesh out the verbose variant and then add--- a single client debug option that flips verbosity------ | Visualize atomic actions sent to the client. This is done--- in the global state after the command is executed and after--- the client state is modified by the command.-displayRespUpdAtomicUI :: MonadClientUI m-                       => Bool -> State -> StateClient -> UpdAtomic -> m ()-displayRespUpdAtomicUI verbose _oldState oldStateClient cmd = case cmd of-  -- Create/destroy actors and items.-  UpdCreateActor aid body _ -> createActorUI aid body verbose "appear"-  UpdDestroyActor aid body _ -> do-    destroyActorUI aid body "die" "be destroyed" verbose-    side <- getsClient sside-    when (bfid body == side && not (bproj body)) stopPlayBack-  UpdCreateItem iid _ k c -> do-    -- TODO: probably not Nothing if container not CGround-    updateItemSlot Nothing iid-    itemVerbMU iid k (MU.Text $ "appear" <+> ppContainer c) (storeFromC c)-    stopPlayBack-  UpdDestroyItem iid _ k c -> itemVerbMU iid k "disappear" (storeFromC c)-  UpdSpotActor aid body _ -> createActorUI aid body verbose "be spotted"-  UpdLoseActor aid body _ ->-    destroyActorUI aid body "be missing in action" "be lost" verbose-  UpdSpotItem iid _ k c -> do-    -- We assign slots to all items visible on the floor,-    -- but some of the slots are later on recycled and then-    -- we report spotting the items again.-    (letterSlots, numberSlots) <- getsClient sslots-    case ( lookup iid $ map swap $ EM.assocs letterSlots-         , lookup iid $ map swap $ IM.assocs numberSlots ) of-      (Nothing, Nothing) -> do-        updateItemSlot Nothing iid-        case c of-          CActor{} -> return ()  -- not actionable at this time-          CFloor lid p -> do-            scursorOld <- getsClient scursor-            case scursorOld of-              TEnemy{} -> return ()  -- probably too important to overwrite-              TEnemyPos{} -> return ()-              _ -> modifyClient $ \cli -> cli {scursor = TPoint lid p}-            itemVerbMU iid k "be spotted" CGround-            stopPlayBack-          CTrunk{} -> return ()-      _ -> return ()  -- seen recently (still has a slot assigned)-  UpdLoseItem{} -> skip-  -- Move actors and items.-  UpdMoveActor aid _ _ -> lookAtMove aid-  UpdWaitActor aid _ -> when verbose $ aVerbMU aid "wait"-  UpdDisplaceActor source target -> displaceActorUI source target-  UpdMoveItem iid k aid c1 c2 -> moveItemUI verbose iid k aid c1 c2-  -- Change actor attributes.-  UpdAgeActor{} -> skip-  UpdRefillHP aid n -> do-    when verbose $-      aVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")-                              <+> tshow (abs n) <> "HP"-    mleader <- getsClient _sleader-    when (Just aid == mleader) $ do-      b <- getsState $ getActorBody aid-      hpMax <- sumOrganEqpClient Effect.EqpSlotAddMaxHP aid-      when (bhp b == xM hpMax && hpMax > 0) $ do-        actorVerbMU aid b "recover your health fully"-        stopPlayBack-  UpdRefillCalm aid calmDelta ->-    when (calmDelta == minusM) $ do  -- lower deltas come from hits; obvious-      side <- getsClient sside-      b <- getsState $ getActorBody aid-      when (bfid b == side) $ do-        fact <- getsState $ (EM.! bfid b) . sfactionD-        allFoes  <- getsState $ actorRegularList (isAtWar fact) (blid b)-        let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes-        when (null closeFoes) $ do  -- obvious where the feeling comes from-          aVerbMU aid "hear something"-          msgDuplicateScrap-  UpdOldFidActor{} -> skip-  UpdTrajectory{} -> skip-  UpdColorActor{} -> skip-  -- Change faction attributes.-  UpdQuitFaction fid mbody _ toSt -> quitFactionUI fid mbody toSt-  UpdLeadFaction fid (Just source) (Just target) -> do-    cops <- getsState scops-    side <- getsClient sside-    when (fid == side) $ do-      fact <- getsState $ (EM.! side) . sfactionD-      -- All-movers can't run with multiple actors, so the following is not-      -- a leader change while running, but rather server changing-      -- their leader, which the player should be alerted to.-      when (isAllMoveFact cops fact) stopPlayBack-      actorD <- getsState sactorD-      case EM.lookup source actorD of-        Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do-          -- Regardless who the leader is, give proper names here, not 'you'.-          tb <- getsState $ getActorBody target-          let subject = partActor tb-              object  = partActor sb-          msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"-                                , "from", object ]-        _ ->-          return ()-          -- TODO: report when server changes spawner's leader;-          -- perhaps don't switch _sleader in HandleAtomicClient,-          -- compare here and switch here? too hacky? fails for AI?-  UpdLeadFaction{} -> skip-  UpdDiplFaction fid1 fid2 _ toDipl -> do-    name1 <- getsState $ gname . (EM.! fid1) . sfactionD-    name2 <- getsState $ gname . (EM.! fid2) . sfactionD-    let showDipl Unknown = "unknown to each other"-        showDipl Neutral = "in neutral diplomatic relations"-        showDipl Alliance = "allied"-        showDipl War = "at war"-    msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."-  UpdAutoFaction{} -> skip-  UpdRecordKill{} -> skip-  -- Alter map.-  UpdAlterTile{} -> when verbose $ return ()  -- TODO: door opens-  UpdAlterClear _ k -> msgAdd $ if k > 0-                                then "You hear grinding noises."-                                else "You hear fizzing noises."-  UpdSearchTile aid p fromTile toTile -> do-    Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    subject <- partAidLeader aid-    let t = lvl `at` p-        verb | t == toTile = "confirm"-             | otherwise = "reveal"-        subject2 = MU.Text $ tname $ okind fromTile-        verb2 = "be"-    let msg = makeSentence [ MU.SubjectVerbSg subject verb-                           , "that the"-                           , MU.SubjectVerbSg subject2 verb2-                           , "a hidden"-                           , MU.Text $ tname $ okind toTile ]-    msgAdd msg-  UpdLearnSecrets{} -> skip-  UpdSpotTile{} -> skip-  UpdLoseTile{} -> skip-  UpdAlterSmell{} -> skip-  UpdSpotSmell{} -> skip-  UpdLoseSmell{} -> skip-  -- Assorted.-  UpdAgeGame {} -> skip-  UpdDiscover _ _ iid _ _ -> discover oldStateClient iid-  UpdCover{} ->  skip  -- don't spam when doing undo-  UpdDiscoverKind _ _ iid _ -> discover oldStateClient iid-  UpdCoverKind{} ->  skip  -- don't spam when doing undo-  UpdDiscoverSeed _ _ iid _ -> discover oldStateClient iid-  UpdCoverSeed{} -> skip  -- don't spam when doing undo-  UpdPerception{} -> skip-  UpdRestart _ _ _ _ _ _ -> do-    mode <- getModeClient-    msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode-    -- TODO: use a vertical animation instead, e.g., roll down,-    -- and reveal the first frame of a new game, not blank screen.-    history <- getsClient shistory-    when (lengthHistory history > 1) $ fadeOutOrIn False-  UpdRestartServer{} -> skip-  UpdResume{} -> skip-  UpdResumeServer{} -> skip-  UpdKillExit{} -> skip-  UpdSaveBkp -> when verbose $ msgAdd "Saving backup."-  UpdMsgAll msg -> msgAdd msg-  UpdRecordHistory _ -> recordHistory--lookAtMove :: MonadClientUI m => ActorId -> m ()-lookAtMove aid = do-  body <- getsState $ getActorBody aid-  side <- getsClient sside-  tgtMode <- getsClient stgtMode-  when (not (bproj body)-        && bfid body == side-        && isNothing tgtMode) $ do  -- targeting does a more extensive look-    lookMsg <- lookAt False "" True (bpos body) aid ""-    msgAdd lookMsg-  fact <- getsState $ (EM.! bfid body) . sfactionD-  if side == bfid body then do-    foes <- getsState $ actorList (isAtWar fact) (blid body)-    when (any (adjacent (bpos body) . bpos) foes) stopPlayBack-  else when (isAtWar fact side) $ do-    friends <- getsState $ actorRegularList (== side) (blid body)-    when (any (adjacent (bpos body) . bpos) friends) stopPlayBack---- | Sentences such as \"Dog barks loudly.\".-actorVerbMU :: MonadClientUI m => ActorId -> Actor -> MU.Part -> m ()-actorVerbMU aid b verb = do-  subject <- partActorLeader aid b-  msgAdd $ makeSentence [MU.SubjectVerbSg subject verb]--aVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()-aVerbMU aid verb = do-  b <- getsState $ getActorBody aid-  actorVerbMU aid b verb--itemVerbMU :: MonadClientUI m-           => ItemId -> Int -> MU.Part -> CStore -> m ()-itemVerbMU iid k verb cstore = assert (k > 0) $ do-  itemToF <- itemToFullClient-  let subject = partItemWs k cstore (itemToF iid k)-      msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]-          | otherwise = makeSentence [MU.SubjectVerbSg subject verb]-  msgAdd msg--aiVerbMU :: MonadClientUI m-         => ActorId -> MU.Part -> ItemId -> Int -> CStore -> m ()-aiVerbMU aid verb iid k cstore = do-  itemToF <- itemToFullClient-  subject <- partAidLeader aid-  let msg = makeSentence [ MU.SubjectVerbSg subject verb-                         , partItemWs k cstore (itemToF iid k) ]-  msgAdd msg--msgDuplicateScrap :: MonadClientUI m => m ()-msgDuplicateScrap = do-  report <- getsClient sreport-  history <- getsClient shistory-  let (lastMsg, repRest) = lastMsgOfReport report-      lastDup = isJust . findInReport (== lastMsg)-      lastDuplicated = lastDup repRest-                       || maybe False lastDup (lastReportOfHistory history)-  when lastDuplicated $-    modifyClient $ \cli -> cli {sreport = repRest}---- TODO: "XXX spots YYY"? or blink or show the changed cursor?-createActorUI :: MonadClientUI m => ActorId -> Actor -> Bool -> MU.Part -> m ()-createActorUI aid body verbose verb = do-  side <- getsClient sside-  when (bfid body /= side && not (bproj body) || verbose) $-    actorVerbMU aid body verb-  when (bfid body /= side) $ do-    fact <- getsState $ (EM.! bfid body) . sfactionD-    when (not (bproj body) && isAtWar fact side) $ do-      -- Target even if nobody can aim at the enemy. Let's home in on him-      -- and then we can aim or melee. We set permit to False, because it's-      -- technically very hard to check aimability here, because we are-      -- in-between turns and, e.g., leader's move has not yet been taken-      -- into account.-      modifyClient $ \cli -> cli {scursor = TEnemy aid False}-    stopPlayBack-  when (bfid body == side && not (bproj body)) $ lookAtMove aid--destroyActorUI :: MonadClientUI m-               => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m ()-destroyActorUI aid body verb verboseVerb verbose = do-  side <- getsClient sside-  if (bfid body == side && bhp body <= 0 && not (bproj body)) then do-    actorVerbMU aid body verb-    void $ displayMore ColorBW ""-  else when verbose $ actorVerbMU aid body verboseVerb--moveItemUI :: MonadClientUI m-           => Bool -> ItemId -> Int -> ActorId -> CStore -> CStore-           -> m ()-moveItemUI verbose iid k aid c1 c2 = do-  side <- getsClient sside-  b <- getsState $ getActorBody aid-  case (c1, c2) of-    (_, _) | c1 == CGround -> do-      when (bfid b == side) $ updateItemSlot (Just aid) iid-      fact <- getsState $ (EM.! bfid b) . sfactionD-      let underAI = playerAI $ gplayer fact-      mleader <- getsClient _sleader-      if Just aid == mleader && not underAI then do-        itemToF <- itemToFullClient-        (letterSlots, _) <- getsClient sslots-        bag <- getsState $ getCBag $ CActor aid c2-        let n = bag EM.! iid-        case lookup iid $ map swap $ EM.assocs letterSlots of-          Just l -> msgAdd $ makePhrase-                      [ "\n"-                      , slotLabel $ Left l-                      , "-"-                      , partItemWs n c2 (itemToF iid n)-                      , "\n" ]-          Nothing -> return ()-      else when (c1 == CGround && c1 /= c2) $-        aiVerbMU aid "get" iid k c2-    (_, CGround) | c1 /= c2 -> do-      when verbose $ aiVerbMU aid "drop" iid k c1-      if bfid b == side-        then updateItemSlot (Just aid) iid-        else updateItemSlot Nothing iid-    _ -> return ()--displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m ()-displaceActorUI source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  spart <- partActorLeader source sb-  tpart <- partActorLeader target tb-  let msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart]-  msgAdd msg-  when (bfid sb /= bfid tb) $ do-    lookAtMove source-    lookAtMove target-  let ps = (bpos tb, bpos sb)-  animFrs <- animate (blid sb) $ swapPlaces ps-  displayActorStart sb animFrs--quitFactionUI :: MonadClientUI m-              => FactionId -> Maybe Actor -> Maybe Status -> m ()-quitFactionUI fid mbody toSt = do-  cops@Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops-  fact <- getsState $ (EM.! fid) . sfactionD-  let fidName = MU.Text $ gname fact-      horror = isHorrorFact cops fact-  side <- getsClient sside-  let msgIfSide _ | fid /= side = Nothing-      msgIfSide s = Just s-      (startingPart, partingPart) = case toSt of-        _ | horror ->-          (Nothing, Nothing)  -- Ignore summoned actors' factions.-        Just Status{stOutcome=Killed} ->-          ( Just "be eliminated"-          , msgIfSide "Let's hope another party can save the day!" )-        Just Status{stOutcome=Defeated} ->-          ( Just "be decisively defeated"-          , msgIfSide "Let's hope your new overlords let you live." )-        Just Status{stOutcome=Camping} ->-          ( Just "order save and exit"-          , Just $ if fid == side-                   then "See you soon, stronger and braver!"-                   else "See you soon, stalwart warrior!" )-        Just Status{stOutcome=Conquer} ->-          ( Just "vanquish all foes"-          , msgIfSide "Can it be done in a better style, though?" )-        Just Status{stOutcome=Escape} ->-          ( Just "achieve victory"-          , msgIfSide "Can it be done better, though?" )-        Just Status{stOutcome=Restart, stInfo} ->-          ( Just $ MU.Text $ "order mission restart in" <+> stInfo <+> "mode"-          , Just $ if fid == side-                   then "This time for real."-                   else "Somebody couldn't stand the heat." )-        Nothing ->-          (Nothing, Nothing)  -- Wipe out the quit flag for the savegame files.-  case startingPart of-    Nothing -> return ()-    Just sp -> do-      let msg = makeSentence [MU.SubjectVerbSg fidName sp]-      msgAdd msg-  case (toSt, partingPart) of-    (Just status, Just pp) -> do-      (bag, total) <- case mbody of-        Just body | fid == side -> getsState $ calculateTotal body-        _ -> case gleader fact of-          Nothing -> return (EM.empty, 0)-          Just aid -> do-            b <- getsState $ getActorBody aid-            getsState $ calculateTotal b-      let currencyName = MU.Text $ iname $ okind $ ouniqGroup "currency"-          itemMsg = makeSentence [ "Your loot is worth"-                                 , MU.CarWs total currencyName ]-                    <+> moreMsg-      startingSlide <- promptToSlideshow moreMsg-      recordHistory  -- we are going to exit or restart, so record-      itemSlides <--        if EM.null bag then return mempty-        else do-          io <- itemOverlay CGround bag-          overlayToSlideshow itemMsg io-      -- Show score for any UI client, even though it is saved only-      -- for human UI clients.-      scoreSlides <- scoreToSlideshow total status-      partingSlide <- promptToSlideshow $ pp <+> moreMsg-      shutdownSlide <- promptToSlideshow pp-      -- TODO: First ESC cancels items display.-      void $ getInitConfirms ColorFull []-           $ startingSlide <> itemSlides-      -- TODO: Second ESC cancels high score and parting message display.-      -- The last slide stays onscreen during shutdown, etc.-             <> scoreSlides <> partingSlide <> shutdownSlide-      -- TODO: perhaps use a vertical animation instead, e.g., roll down-      -- and put it before item and score screens (on blank background)-      unless (fmap stOutcome toSt == Just Camping) $ fadeOutOrIn True-    _ -> return ()--discover :: MonadClientUI m => StateClient -> ItemId ->  m ()-discover oldcli iid = do-  cops <- getsState scops-  itemToF <- itemToFullClient-  let itemFull = itemToF iid 1-      (knownName, knownAEText) = partItem CGround itemFull-      -- Wipe out the whole knowledge of the item to make sure the two names-      -- in the message differ even if, e.g., the item is described as-      -- "of many effects".-      itemSecret = itemNoDisco (itemBase itemFull, itemK itemFull)-      (secretName, secretAEText) = partItem CGround itemSecret-      msg = makeSentence-        [ "the", MU.SubjectVerbSg (MU.Phrase [secretName, secretAEText])-                                  "turn out to be"-        , MU.AW $ MU.Phrase [knownName, knownAEText] ]-      oldItemFull =-        itemToFull cops (sdisco oldcli) (sdiscoAE oldcli)-                   iid (itemBase itemFull) 1-  -- Compare descriptions of all aspects and effects to determine-  -- if the discovery was meaningful to the player.-  when (textAllAE False CEqp itemFull /= textAllAE False CEqp oldItemFull) $-    msgAdd msg---- * RespSfxAtomicUI---- | Display special effects (text, animation) sent to the client.-displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m ()-displayRespSfxAtomicUI verbose sfx = case sfx of-  SfxStrike source target iid b -> strike source target iid b-  SfxRecoil source target _ _ -> do-    spart <- partAidLeader source-    tpart <- partAidLeader target-    msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]-  SfxProject aid iid -> aiVerbMU aid "aim" iid 1 CInv-  SfxCatch aid iid -> aiVerbMU aid "catch" iid 1 CInv-  SfxActivate aid iid k -> aiVerbMU aid "activate" iid k CInv-  SfxCheck aid iid k -> aiVerbMU aid "deactivate" iid k CInv-  SfxTrigger aid _p _feat ->-    when verbose $ aVerbMU aid "trigger"  -- TODO: opens door, etc.-  SfxShun aid _p _ ->-    when verbose $ aVerbMU aid "shun"  -- TODO: shuns stairs down-  SfxEffect fidSource aid effect -> do-    b <- getsState $ getActorBody aid-    side <- getsClient sside-    let fid = bfid b-    if bhp b <= 0 && not (bproj b) || bhp b < 0 then do-      -- We assume the effect is the cause of incapacitation.-      let firstFall | fid == side && bproj b = "fall apart"-                    | fid == side = "fall down"-                    | bproj b = "break up"-                    | otherwise = "collapse"-          hurtExtra | fid == side && bproj b = "be reduced to dust"-                    | fid == side = "be stomped flat"-                    | bproj b = "be shattered into little pieces"-                    | otherwise = "be reduced to a bloody pulp"-      subject <- partActorLeader aid b-      let deadPreviousTurn p = p < 0-                               && (bhp b <= p && not (bproj b)-                                   || bhp b < p)-          (deadBefore, verbDie) =-            case effect of-              Effect.Hurt p | deadPreviousTurn (xM $ Dice.maxDice p) ->-                (True, hurtExtra)-              Effect.RefillHP p | deadPreviousTurn (xM p) -> (True, hurtExtra)-              _ -> (False, firstFall)-          msgDie = makeSentence [MU.SubjectVerbSg subject verbDie]-      msgAdd msgDie-      when (fid == side && not (bproj b)) $ do-        animDie <- if deadBefore-                   then animate (blid b)-                        $ twirlSplash (bpos b, bpos b) Color.Red Color.Red-                   else animate (blid b) $ deathBody $ bpos b-        displayActorStart b animDie-    else case effect of-        Effect.NoEffect t -> msgAdd $ "Nothing happens." <+> t-        Effect.RefillHP p | p == 1 -> skip  -- no spam from regen items-        Effect.RefillHP p | p > 0 -> do-          if fid == side then-            actorVerbMU aid b "feel healthier"-          else-            actorVerbMU aid b "look healthier"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue-          displayActorStart b animFrs-        Effect.RefillHP _ -> do-          if fid == side then-            actorVerbMU aid b "feel wounded"-          else-            actorVerbMU aid b "look wounded"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red-          displayActorStart b animFrs-        Effect.Hurt{} -> skip  -- avoid spam; SfxStrike just sent-        Effect.RefillCalm p | p == 1 -> skip  -- no spam from regen items-        Effect.RefillCalm p | p > 0 -> do-          if fid == side then-            actorVerbMU aid b "feel calmer"-          else-            actorVerbMU aid b "look calmer"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue-          displayActorStart b animFrs-        Effect.RefillCalm _ -> do-          if fid == side then-            actorVerbMU aid b "feel agitated"-          else-            actorVerbMU aid b "look agitated"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red-          displayActorStart b animFrs-        Effect.Dominate -> do-          -- For subsequent messages use the proper name, never "you".-          let subject = partActor b-          if fid /= fidSource then do  -- before domination-            if bcalm b == 0 then do -- sometimes only a coincidence, but nm-              aVerbMU aid $ MU.Text "yield, under extreme pressure"-            else if fid == side then-              aVerbMU aid $ MU.Text "black out, dominated by foes"-            else-              aVerbMU aid $ MU.Text "decide abrubtly to switch allegiance"-            fidName <- getsState $ gname . (EM.! fid) . sfactionD-            let verb = "be no longer controlled by"-            msgAdd $ makeSentence-              [MU.SubjectVerbSg subject verb, MU.Text fidName]-            when (fid == side) $ void $ displayMore ColorFull ""-          else do-            fidSourceName <- getsState $ gname . (EM.! fidSource) . sfactionD-            let verb = "be now under"-            msgAdd $ makeSentence-              [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]-        Effect.Impress{} ->-          actorVerbMU aid b-          $ if boldfid b /= bfid b-            then-              "get sobered and refocused by the fragrant moisture"-            else-              "inhale the sweet smell that weakens resolve and erodes loyalty"-        Effect.CallFriend{} -> skip-        Effect.Summon{} -> skip-        Effect.CreateItem{} -> skip-        Effect.ApplyPerfume ->-          msgAdd "The fragrance quells all scents in the vicinity."-        Effect.Burn{} ->-          if fid == side then-            actorVerbMU aid b "feel burned"-          else-            actorVerbMU aid b "look burned"-        Effect.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs"-        Effect.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs"-        Effect.Ascend{} -> assert `failure` sfx-        Effect.Escape{} -> skip-        Effect.Paralyze{} -> actorVerbMU aid b "be paralyzed"-        Effect.InsertMove{} -> actorVerbMU aid b "move with extreme speed"-        Effect.DropBestWeapon -> actorVerbMU aid b "be disarmed"-        Effect.DropEqp _ False -> actorVerbMU aid b "be stripped"  -- TODO-        Effect.DropEqp _ True -> actorVerbMU aid b "be violently stripped"-        Effect.SendFlying{} -> actorVerbMU aid b "be sent flying"-        Effect.PushActor{} -> actorVerbMU aid b "be pushed"-        Effect.PullActor{} -> actorVerbMU aid b "be pulled"-        Effect.Teleport t | t > 9 -> actorVerbMU aid b "teleport"-        Effect.Teleport{} -> actorVerbMU aid b "blink"-        Effect.PolyItem cstore -> do-          allAssocs <- fullAssocsClient aid [cstore]-          case allAssocs of-            [] -> return ()  -- invisible items?-            (_, ItemFull{..}) : _ -> do-              let itemSecret = itemNoDisco (itemBase, itemK)-                  (secretName, secretAEText) = partItem cstore itemSecret-                  subject = partActor b-                  verb = "repurpose"-                  store = MU.Text $ ppCStore cstore-              msgAdd $ makeSentence-                [ MU.SubjectVerbSg subject verb-                , "the", secretName, secretAEText, store ]-        Effect.Identify cstore -> do-          allAssocs <- fullAssocsClient aid [cstore]-          case allAssocs of-            [] -> return ()  -- invisible items?-            (_, ItemFull{..}) : _ -> do-              let itemSecret = itemNoDisco (itemBase, itemK)-                  (secretName, secretAEText) = partItem cstore itemSecret-                  subject = partActor b-                  verb = "compare"-                  store = MU.Text $ ppCStore cstore-              msgAdd $ makeSentence-                [ MU.SubjectVerbSg subject verb-                , "old notes with the", secretName, secretAEText, store ]-        Effect.ActivateInv{} -> skip-        Effect.Explode{} -> skip  -- lots of visual feedback-        Effect.OneOf{} -> skip-        Effect.OnSmash{} -> assert `failure` sfx-        Effect.TimedAspect{} -> skip  -- TODO-  SfxMsgFid _ msg -> msgAdd msg-  SfxMsgAll msg -> msgAdd msg-  SfxActorStart aid -> do-    arena <- getArenaUI-    b <- getsState $ getActorBody aid-    activeItems <- activeItemsClient aid-    when (blid b == arena) $ do-      -- If time clip has passed since any actor advanced level time-      -- or if the actor is so fast that he was capable of already moving-      -- this clip (for simplicity, we don't check if he actually did)-      -- or if the actor is newborn or is about to die,-      -- we end the frame early, before his current move.-      -- In the result, he moves at most once per frame, and thanks to this,-      -- his multiple moves are not collapsed into one frame.-      -- If the actor changes his speed this very clip, the test can faii,-      -- but it's rare and results in a minor UI issue, so we don't care.-      timeCutOff <- getsClient $ EM.findWithDefault timeZero arena . sdisplayed-      when (btime b >= timeShift timeCutOff (Delta timeClip)-            || btime b >= timeShiftFromSpeed b activeItems timeCutOff-            || actorNewBorn b-            || actorDying b) $ do-        let ageDisp displayed = EM.insert arena (btime b) displayed-        modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}-        -- If considerable time passed, show delay.-        let delta = btime b `timeDeltaToFrom` timeCutOff-        when (delta > Delta timeClip) displayDelay-        -- If key will be requested, don't show the frame, because during-        -- the request extra message may be shown, so the other frame is better.-        mleader <- getsClient _sleader-        fact <- getsState $ (EM.! bfid b) . sfactionD-        let underAI = playerAI $ gplayer fact-        unless (Just aid == mleader && not underAI) $-          -- Something new is gonna happen on this level (otherwise we'd send-          -- @UpdAgeLevel@ later on, with a larger time increment),-          -- so show crrent game state, before it changes.-          displayPush--strike :: MonadClientUI m-       => ActorId -> ActorId -> ItemId -> HitAtomic -> m ()-strike source target iid hitStatus = assert (source /= target) $ do-  itemToF <- itemToFullClient-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  spart <- partActorLeader source sb-  tpart <- partActorLeader target tb-  spronoun <- partPronounLeader source sb-  let itemFull = itemToF iid 1-      verb = case itemDisco itemFull of-        Nothing -> "hit"  -- not identified-        Just ItemDisco{itemKind} -> iverbHit itemKind-      isOrgan = iid `EM.member` borgan sb-      partItemChoice = if isOrgan-                       then partItemWownW spronoun COrgan-                       else partItemAW CEqp-      msg HitClear = makeSentence $-        [MU.SubjectVerbSg spart verb, tpart]-        ++ if bproj sb-           then []-           else ["with", partItemChoice itemFull]-      msg (HitBlock n) =-        let sActs =-              if bproj sb-              then [ MU.SubjectVerbSg spart "connect" ]-              else [ MU.SubjectVerbSg spart "swing"-                   , partItemChoice itemFull ]-        in makeSentence [ MU.Phrase sActs MU.:> ", but"-                        , MU.SubjectVerbSg tpart "block"-                        , if n > 1 then "doggedly" else "partly"-                        ]--- TODO: when other armor is in, etc.:---      msg HitSluggish =---        let adv = MU.Phrase ["sluggishly", verb]---        in makeSentence $ [MU.SubjectVerbSg spart adv, tpart]---                          ++ ["with", partItemChoice itemFull]-  msgAdd $ msg hitStatus-  let ps = (bpos tb, bpos sb)-      anim HitClear = twirlSplash ps Color.BrRed Color.Red-      anim (HitBlock 1) = blockHit ps Color.BrRed Color.Red-      anim (HitBlock _) = blockMiss ps-  animFrs <- animate (blid sb) $ anim hitStatus-  displayActorStart sb animFrs
− Game/LambdaHack/Client/UI/DrawClient.hs 
@@ -1,384 +0,0 @@--- | Display game data on the screen using one of the available frontends--- (determined at compile time with cabal flags).-module Game.LambdaHack.Client.UI.DrawClient-  ( ColorMode(..)-  , draw-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import qualified Data.IntMap.Strict as IM-import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Common.Actor as Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind---- | Color mode for the display.-data ColorMode =-    ColorFull  -- ^ normal, with full colours-  | ColorBW    -- ^ black+white only---- TODO: split up and generally rewrite.--- | Draw the whole screen: level map and status area.--- Pass at most a single page if overlay of text unchanged--- to the frontends to display separately or overlay over map,--- depending on the frontend.-draw :: MonadClient m-     => Bool -> ColorMode -> LevelId-     -> Maybe Point -> Maybe Point-     -> Maybe (PointArray.Array BfsDistance, Maybe [Point])-     -> (Text, Maybe Text) -> (Text, Maybe Text) -> Overlay-     -> m SingleFrame-draw sfBlank dm drawnLevelId cursorPos tgtPos bfsmpathRaw-     (cursorDesc, mcursorHP) (targetDesc, mtargetHP) sfTop = do-  cops <- getsState scops-  mleader <- getsClient _sleader-  s <- getState-  cli@StateClient{ stgtMode, seps, sexplored-                 , smarkVision, smarkSmell, smarkSuspect, swaitTimes }-    <- getClient-  per <- getPerFid drawnLevelId-  let Kind.COps{cotile=cotile@Kind.Ops{okind=tokind, ouniqGroup}} = cops-      (lvl@Level{lxsize, lysize, lsmell, ltime}) = sdungeon s EM.! drawnLevelId-      (bl, mblid, mbpos) = case (cursorPos, mleader) of-        (Just cursor, Just leader) ->-          let Actor{bpos, blid} = getActorBody leader s-          in if blid /= drawnLevelId-             then ( [cursor], Just blid, Just bpos )-             else ( fromMaybe [] $ bla lxsize lysize seps bpos cursor-                  , Just blid-                  , Just bpos )-        _ -> ([], Nothing, Nothing)-      mpath = maybe Nothing (\(_, mp) -> if null bl-                                            || mblid /= Just drawnLevelId-                                         then Nothing-                                         else mp) bfsmpathRaw-      actorsHere = actorAssocs (const True) drawnLevelId s-      cursorHere = find (\(_, m) -> cursorPos == Just (Actor.bpos m))-                   actorsHere-      shiftedBTrajectory = case cursorHere of-        Just (_, Actor{btrajectory = Just p, bpos = prPos}) ->-          trajectoryToPath prPos (fst p)-        _ -> []-      unknownId = ouniqGroup "unknown space"-      dis pos0 =-        let tile = lvl `at` pos0-            tk = tokind tile-            floorBag = lvl `atI` pos0-            (letterSlots, numberSlots) = sslots cli-            bagLetterSlots = EM.filter (`EM.member` floorBag) letterSlots-            bagNumberSlots = IM.filter (`EM.member` floorBag) numberSlots-            floorIids = reverse (EM.elems bagLetterSlots)-                        ++ IM.elems bagNumberSlots-                        ++ EM.keys floorBag-            sml = EM.findWithDefault timeZero pos0 lsmell-            smlt = sml `timeDeltaToFrom` ltime-            viewActor aid Actor{bsymbol, bcolor, bhp, bproj}-              | Just aid == mleader = (symbol, inverseVideo)-              | otherwise = (symbol, Color.defAttr {Color.fg = bcolor})-             where-              symbol | bhp <= 0 && not bproj = '%'-                     | otherwise = bsymbol-            rainbow p = Color.defAttr {Color.fg =-                                         toEnum $ fromEnum p `rem` 14 + 1}-            -- smarkSuspect is an optional overlay, so let's overlay it-            -- over both visible and invisible tiles.-            vcolor-              | smarkSuspect && Tile.isSuspect cotile tile = Color.BrCyan-              | vis = tcolor tk-              | otherwise = tcolor2 tk-            fgOnPathOrLine = case (vis, Tile.isWalkable cotile tile) of-              _ | tile == unknownId -> Color.BrBlack-              _ | Tile.isSuspect cotile tile -> Color.BrCyan-              (True, True)   -> Color.BrGreen-              (True, False)  -> Color.BrRed-              (False, True)  -> Color.Green-              (False, False) -> Color.Red-            atttrOnPathOrLine = if Just pos0 == cursorPos-                                then inverseVideo {Color.fg = fgOnPathOrLine}-                                else Color.defAttr {Color.fg = fgOnPathOrLine}-            (char, attr0) =-              case find (\(_, m) -> pos0 == Actor.bpos m) actorsHere of-                _ | isJust stgtMode-                    && (elem pos0 bl || elem pos0 shiftedBTrajectory) ->-                  ('*', atttrOnPathOrLine)  -- line takes precedence over path-                _ | isJust stgtMode-                    && (maybe False (elem pos0) mpath) ->-                  (';', Color.defAttr {Color.fg = fgOnPathOrLine})-                Just (aid, m) -> viewActor aid m-                _ | smarkSmell && smlt > Delta timeZero ->-                  (timeDeltaToDigit smellTimeout smlt, rainbow pos0)-                  | otherwise ->-                  case floorIids of-                    [] -> (tsymbol tk, Color.defAttr {Color.fg = vcolor})-                    iid : _ -> viewItem $ getItemBody iid s-            vis = ES.member pos0 $ totalVisible per-            a = case dm of-                  ColorBW -> Color.defAttr-                  ColorFull -> if smarkVision && vis-                               then attr0 {Color.bg = Color.Blue}-                               else attr0-        in Color.AttrChar a char-      widthX = 80-      widthTgt = 39-      widthStats = widthX - widthTgt-      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      arenaStatus = drawArenaStatus (ES.member drawnLevelId sexplored) lvl-                                    widthStats-      displayPathText mp mt =-        let (plen, llen) = case (mp, bfsmpathRaw, mbpos) of-              (Just target, Just (bfs, _), Just bpos)-                | mblid == Just drawnLevelId ->-                  (fromMaybe 0 (accessBfs bfs target), chessDist bpos target)-              _ -> (0, 0)-            pText | plen == 0 = ""-                  | otherwise = "p" <> tshow plen-            lText | llen == 0 = ""-                  | otherwise = "l" <> tshow llen-            text = fromMaybe (pText <+> lText) mt-        in if T.null text then "" else " " <> text-      -- The indicators must fit, they are the actual information.-      pathCsr = displayPathText cursorPos mcursorHP-      trimTgtDesc n t = assert (not (T.null t) && n > 2) $-        if T.length t <= n then t-        else let ellipsis = "..."-                 fitsPlusOne = T.take (n - T.length ellipsis + 1) t-                 fits = if T.last fitsPlusOne == ' '-                        then T.init fitsPlusOne-                        else let lw = T.words fitsPlusOne-                             in T.unwords $ init lw-             in fits <> ellipsis-      cursorText =-        let n = widthTgt - T.length pathCsr - 8-        in (if isJust stgtMode then "cursor>" else "Cursor:")-           <+> trimTgtDesc n cursorDesc-      cursorGap = T.replicate (widthTgt - T.length pathCsr-                                        - T.length cursorText) " "-      cursorStatus = addAttr $ cursorText <> cursorGap <> pathCsr-      minLeaderStatusWidth = 19  -- covers 3-digit HP-  selectedStatus <- drawSelected drawnLevelId-                                 (widthStats - minLeaderStatusWidth)-  leaderStatus <- drawLeaderStatus swaitTimes-                                   (widthStats - length selectedStatus)-  damageStatus <- drawLeaderDamage (widthStats - length leaderStatus-                                               - length selectedStatus)-  nameStatus <- drawPlayerName (widthStats - length leaderStatus-                                           - length selectedStatus-                                           - length damageStatus)-  let statusGap = addAttr $ T.replicate (widthStats - length leaderStatus-                                                    - length selectedStatus-                                                    - length damageStatus-                                                    - length nameStatus) " "-      -- The indicators must fit, they are the actual information.-      pathTgt = displayPathText tgtPos mtargetHP-      targetText =-        let n = widthTgt - T.length pathTgt - 8-        in "Target:" <+> trimTgtDesc n targetDesc-      targetGap = T.replicate (widthTgt - T.length pathTgt-                                        - T.length targetText) " "-      targetStatus = addAttr $ targetText <> targetGap <> pathTgt-      sfBottom =-        [ encodeLine $ arenaStatus ++ cursorStatus-        , encodeLine $ selectedStatus ++ nameStatus ++ statusGap-                       ++ damageStatus ++ leaderStatus-                       ++ targetStatus ]-      fLine y = encodeLine $-        let f l x = let ac = dis $ Point x y in ac : l-        in foldl' f [] [lxsize-1,lxsize-2..0]-      sfLevel =  -- fully evaluated-        let f l y = let !line = fLine y in line : l-        in foldl' f [] [lysize-1,lysize-2..0]-  return $! SingleFrame{..}--inverseVideo :: Color.Attr-inverseVideo = Color.Attr { Color.fg = Color.bg Color.defAttr-                          , Color.bg = Color.fg Color.defAttr }---- Comfortably accomodates 3-digit level numbers and 25-character--- level descriptions (currently enforced max).-drawArenaStatus :: Bool -> Level -> Int -> [Color.AttrChar]-drawArenaStatus explored Level{ldepth=AbsDepth ld, ldesc, lseen, lclear} width =-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      seenN = 100 * lseen `div` max 1 lclear-      seenTxt | explored || seenN >= 100 = "all"-              | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%")-      lvlN = T.justifyLeft 2 ' ' (tshow ld)-      seenStatus = "[" <> seenTxt <+> "seen] "-  in addAttr $ T.justifyLeft width ' '-             $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' ldesc) <+> seenStatus--drawLeaderStatus :: MonadClient m => Int -> Int -> m [Color.AttrChar]-drawLeaderStatus waitT width = do-  mleader <- getsClient _sleader-  s <- getState-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      addColor c t = map (Color.AttrChar $ Color.Attr c Color.defBG)-                         (T.unpack t)-      maxLeaderStatusWidth = 23  -- covers 3-digit HP and 2-digit Calm-      (calmHeaderText, hpHeaderText) = if width < maxLeaderStatusWidth-                                       then ("C", "H")-                                       else ("Calm", "HP")-  case mleader of-    Just leader -> do-      activeItems <- activeItemsClient leader-      let (darkL, bracedL, hpDelta, calmDelta,-           ahpS, bhpS, acalmS, bcalmS) =-            let b@Actor{bhp, bcalm} = getActorBody leader s-                amaxHP = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-                amaxCalm = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems-            in ( not (actorInAmbient b s)-               , braced b, bhpDelta b, bcalmDelta b-               , tshow $ max 0 amaxHP, tshow (bhp `divUp` oneM)-               , tshow $ max 0 amaxCalm, tshow (bcalm `divUp` oneM))-          -- This is a valuable feedback for the otherwise hard to observe-          -- 'wait' command.-          slashes = ["/", "|", "\\", "|"]-          slashPick = slashes !! (max 0 (waitT - 1) `mod` length slashes)-          checkDelta ResDelta{..} =-            if resCurrentTurn < 0 || resPreviousTurn < 0-            then addColor Color.BrRed  -- alarming news have priority-            else if resCurrentTurn > 0 || resPreviousTurn > 0-                 then addColor Color.BrGreen-                 else addAttr  -- only if nothing at all noteworthy-          calmAddAttr = checkDelta calmDelta-          darkPick | darkL   = "."-                   | otherwise = ":"-          calmHeader = calmAddAttr $ calmHeaderText <> darkPick-          calmText = bcalmS <>  (if darkL then slashPick else "/") <> acalmS-          bracePick | bracedL   = "}"-                    | otherwise = ":"-          hpAddAttr = checkDelta hpDelta-          hpHeader = hpAddAttr $ hpHeaderText <> bracePick-          hpText = bhpS <> (if bracedL then slashPick else "/") <> ahpS-      return $! calmHeader <> addAttr (T.justifyRight 6 ' ' calmText <> " ")-                <> hpHeader <> addAttr (T.justifyRight 6 ' ' hpText <> " ")-    Nothing -> return $! addAttr $ calmHeaderText <> ": --/-- "-                                   <> hpHeaderText <> ": --/-- "--drawLeaderDamage :: MonadClient m => Int -> m [Color.AttrChar]-drawLeaderDamage width = do-  mleader <- getsClient _sleader-  let addColor t = map (Color.AttrChar $ Color.Attr Color.BrCyan Color.defBG)-                   (T.unpack t)-  stats <- case mleader of-    Just leader -> do-      allAssocs <- fullAssocsClient leader [CEqp, COrgan]-      let activeItems = map snd allAssocs-          damage = case strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of-            (_, (_, itemFull)) : _->-              let getD :: Effect.Effect a -> Maybe Dice.Dice-                       -> Maybe Dice.Dice-                  getD (Effect.Hurt dice) _ = Just dice-                  getD _ acc = acc-                  mdice = case itemDisco itemFull of-                    Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-                      foldr getD Nothing jeffects-                    Just ItemDisco{itemKind} ->-                      foldr getD Nothing (ieffects itemKind)-                    Nothing -> Nothing-                  tdice = case mdice of-                    Nothing -> "0"-                    Just dice -> tshow dice-                  bonus = sumSlotNoFilter Effect.EqpSlotAddHurtMelee activeItems-                  unknownBonus = unknownMelee activeItems-                  tbonus = if bonus == 0-                           then if unknownBonus then "+?" else ""-                           else (if bonus > 0 then "+" else "")-                                <> tshow bonus-                                <> if unknownBonus then "%?" else "%"-             in tdice <> tbonus-            [] -> "0"-      return $! damage-    Nothing -> return ""-  return $! if T.null stats || T.length stats >= width then []-            else addColor $ stats <> " "---- TODO: colour some texts using the faction's colour-drawSelected :: MonadClient m => LevelId -> Int -> m [Color.AttrChar]-drawSelected drawnLevelId width = do-  mleader <- getsClient _sleader-  selected <- getsClient sselected-  side <- getsClient sside-  s <- getState-  let viewOurs (aid, Actor{bsymbol, bcolor, bhp})-        | otherwise =-          let cattr = Color.defAttr {Color.fg = bcolor}-              sattr-               | Just aid == mleader = inverseVideo-               | ES.member aid selected =-                   -- TODO: in the future use a red rectangle instead-                   -- of background and mark them on the map, too;-                   -- also, perhaps blink all selected on the map,-                   -- when selection changes-                   if bcolor /= Color.Blue-                   then cattr {Color.bg = Color.Blue}-                   else cattr {Color.bg = Color.Magenta}-               | otherwise = cattr-          in ( (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid)-             , Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%' )-      ours = filter (not . bproj . snd)-             $ actorAssocs (== side) drawnLevelId s-      maxViewed = width - 2-      -- Don't show anything if the only actor on the level is the leader.-      -- He's clearly highlighted on the level map, anyway.-      star = let sattr = case ES.size selected of-                   0 -> Color.defAttr {Color.fg = Color.BrBlack}-                   n | n == length ours ->-                     Color.defAttr {Color.bg = Color.Blue}-                   _ -> Color.defAttr-                 char = if length ours > maxViewed then '$' else '*'-             in Color.AttrChar sattr char-      viewed = take maxViewed $ sort $ map viewOurs ours-      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      allOurs = filter ((== side) . bfid) $ EM.elems $ sactorD s-      party = if length allOurs <= 1-              then []-              else [star] ++ map snd viewed ++ addAttr " "-  return $! party--drawPlayerName :: MonadClient m => Int -> m [Color.AttrChar]-drawPlayerName width = do-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  let nameN n t =-        let fitWords [] = []-            fitWords l@(_ : rest) = if sum (map T.length l) + length l - 1 > n-                                    then fitWords rest-                                    else l-        in T.unwords $ reverse $ fitWords $ reverse $ T.words t-      ourName = nameN (width - 1) $ playerName $ gplayer fact-  return $! if T.null ourName || T.length ourName >= width-            then []-            else addAttr $ ourName <> " "
− Game/LambdaHack/Client/UI/Frontend.hs 
@@ -1,133 +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.Client.UI.Frontend-  ( -- * Connection types.-    FrontReq(..), ChanFrontend(..)-    -- * Re-exported part of the raw frontend-  , frontendName-    -- * A derived operation-  , startupF-  ) where--import Control.Concurrent-import qualified Control.Concurrent.STM as STM-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.Text.IO as T-import System.IO--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.Frontend.Chosen-import Game.LambdaHack.Common.ClientOptions--data FrontReq =-    FrontNormalFrame {frontFrame :: !SingleFrame}-      -- ^ show a frame-  | FrontRunningFrame {frontFrame :: !SingleFrame}-      -- ^ show a frame in running mode (don't insert delay between frames)-  | FrontDelay-      -- ^ perform a single explicit delay-  | FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}-      -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress-  | FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]}-      -- ^ show a whole slideshow without interleaving with other clients-  | FrontFinish-      -- ^ exit frontend loop---- | Connection channel between a frontend and a client. Frontend acts--- as a server, serving keys, when given frames to display.-data ChanFrontend = ChanFrontend-  { responseF :: !(STM.TQueue K.KM)-  , requestF  :: !(STM.TQueue FrontReq)-  }--startupF :: DebugModeCli-         -> (Maybe (MVar ()) -> (ChanFrontend -> IO ()) -> IO ())-         -> IO ()-startupF dbg cont =-  (if sfrontendNull dbg then nullStartup-   else if sfrontendStd dbg then stdStartup-        else chosenStartup) dbg $ \fs -> do-    cont (fescMVar fs) (loopFrontend fs)-    let debugPrint t = when (sdbgMsgCli dbg) $ do-          T.hPutStrLn stderr t-          hFlush stderr-    debugPrint "Server shuts down"---- | 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 :: RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM-promptGetKey fs [] frame = fpromptGetKey fs frame-promptGetKey fs keys frame = do-  km <- fpromptGetKey fs frame-  if km `elem` keys-    then return km-    else promptGetKey fs keys frame--getConfirmGeneric :: RawFrontend -> [K.KM] -> SingleFrame -> IO (Maybe Bool)-getConfirmGeneric fs clearKeys frame = do-  let DebugModeCli{snoMore} = fdebugCli fs-  -- TODO: turn noMore off somehow when faction not under computer control;-  -- perhaps by adding a FrontReq request that turns it off/on?-  if snoMore then do-    fdisplay fs True (Just frame)-    return $ Just True-  else do-    let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM]-    km <- promptGetKey fs (clearKeys ++ extraKeys) frame-    return $! if km == K.escKM-              then Nothing-              else if km == K.pgupKM-                   then Just False-                   else Just True---- Read UI requests from the client and send them to the frontend,-loopFrontend :: RawFrontend -> ChanFrontend -> IO ()-loopFrontend fs ChanFrontend{..} = loop- where-  writeKM :: K.KM -> IO ()-  writeKM km = STM.atomically $ STM.writeTQueue responseF km--  loop :: IO ()-  loop = do-    efr <- STM.atomically $ STM.readTQueue requestF-    case efr of-      FrontNormalFrame{..} -> do-        fdisplay fs False (Just frontFrame)-        loop-      FrontRunningFrame{..} -> do-        fdisplay fs True (Just frontFrame)-        loop-      FrontDelay -> do-        fdisplay fs False Nothing-        loop-      FrontKey{..} -> do-        km <- promptGetKey fs frontKM frontFr-        writeKM km-        loop-      FrontSlides{frontSlides = []} -> do-        -- Hack.-        fsyncFrames fs-        writeKM K.spaceKM-        loop-      FrontSlides{..} -> do-        let displayFrs frs srf =-              case frs of-                [] -> assert `failure` "null slides" `twith` frs-                [x] -> do-                  fdisplay fs False (Just x)-                  writeKM K.spaceKM-                x : xs -> do-                  go <- getConfirmGeneric fs frontClear x-                  case go of-                    Nothing -> writeKM K.escKM-                    Just True -> displayFrs xs (x : srf)-                    Just False -> case srf of-                      [] -> displayFrs frs srf-                      y : ys -> displayFrs (y : frs) ys-        displayFrs frontSlides []-        loop-      FrontFinish ->-        return ()-        -- Do not loop again.
− Game/LambdaHack/Client/UI/Frontend/Chosen.hs 
@@ -1,68 +0,0 @@-{-# LANGUAGE CPP #-}--- | Re-export the operations of the chosen raw frontend--- (determined at compile time with cabal flags).-module Game.LambdaHack.Client.UI.Frontend.Chosen-  ( RawFrontend(..), chosenStartup, stdStartup, nullStartup-  , frontendName-  ) where--import Control.Concurrent-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation (SingleFrame (..))-import Game.LambdaHack.Common.ClientOptions--#ifdef VTY-import qualified Game.LambdaHack.Client.UI.Frontend.Vty as Chosen-#elif CURSES-import qualified Game.LambdaHack.Client.UI.Frontend.Curses as Chosen-#else-import qualified Game.LambdaHack.Client.UI.Frontend.Gtk as Chosen-#endif--import qualified Game.LambdaHack.Client.UI.Frontend.Std as Std---- | The name of the chosen frontend.-frontendName :: String-frontendName = Chosen.frontendName--data RawFrontend = RawFrontend-  { fdisplay      :: Bool -> Maybe SingleFrame -> IO ()-  , fpromptGetKey :: SingleFrame -> IO K.KM-  , fsyncFrames   :: IO ()-  , fescMVar      :: !(Maybe (MVar ()))-  , fdebugCli     :: !DebugModeCli-  }--chosenStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()-chosenStartup fdebugCli cont =-  Chosen.startup fdebugCli $ \fs ->-    cont $ RawFrontend-      { fdisplay = Chosen.fdisplay fs-      , fpromptGetKey = Chosen.fpromptGetKey fs-      , fsyncFrames = Chosen.fsyncFrames fs-      , fescMVar = Chosen.sescMVar fs-      , fdebugCli-      }--stdStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()-stdStartup fdebugCli cont =-  Std.startup fdebugCli $ \fs ->-    cont $ RawFrontend-      { fdisplay = Std.fdisplay fs-      , fpromptGetKey = Std.fpromptGetKey fs-      , fsyncFrames = Std.fsyncFrames fs-      , fescMVar = Std.sescMVar fs-      , fdebugCli-      }--nullStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()-nullStartup fdebugCli cont =-  -- Std used to fork (async) the server thread, to avoid bound thread overhead.-  Std.startup fdebugCli $ \_ ->-    cont $ RawFrontend-      { fdisplay = \_ _ -> return ()-      , fpromptGetKey = \_ -> return K.escKM-      , fsyncFrames = return ()-      , fescMVar = Nothing-      , fdebugCli-      }
− Game/LambdaHack/Client/UI/Frontend/Curses.hs 
@@ -1,167 +0,0 @@--- | Text frontend based on HSCurses. This frontend is not fully supported--- due to the limitations of the curses library (keys, colours, last character--- of the last line).-module Game.LambdaHack.Client.UI.Frontend.Curses-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Exception as Ex hiding (handle)-import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Char (chr, ord)-import qualified Data.Map.Strict as M-import qualified UI.HSCurses.Curses as C-import qualified UI.HSCurses.CursesHelper as C--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Msg---- | 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-  , sescMVar  :: !(Maybe (MVar ()))-  , sdebugCli :: !DebugModeCli  -- ^ client configuration-  }---- | The name of the frontend.-frontendName :: String-frontendName = "curses"---- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do-  C.start---  C.keypad C.stdScr False  -- TODO: may help to fix xterm keypad on Ubuntu-  void $ C.cursSet C.CursorInvisible-  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 < length s) $-    C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr)-  let (ks, vs) = unzip s-  ws <- C.convertStyles vs-  let swin = C.stdScr-      sstyles = M.fromList (zip ks ws)-  a <- async $ k FrontendSession{sescMVar = Nothing, ..} `Ex.finally` C.end-  wait a---- | Output to the screen via the frontend.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay _ _ Nothing = return ()-fdisplay FrontendSession{..}  _ (Just rawSF) = do-  let SingleFrame{sfLevel} = overlayOverlay rawSF-  -- let defaultStyle = C.defaultCursesStyle-  -- Terminals with white background require this:-  let defaultStyle = sstyles M.! Color.defAttr-  C.erase-  C.setStyle defaultStyle-  -- 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.-  let sfLevelDecoded = map decodeLine sfLevel-      level = init sfLevelDecoded ++ [init $ last sfLevelDecoded]-      nm = zip [0..] $ map (zip [0..]) level-  sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles)-              >> C.mvWAddStr swin (y + 1) x [acChar]-            | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ]-  C.refresh---- | Input key via the frontend.-nextEvent :: IO K.KM-nextEvent = keyTranslate `fmap` C.getKey C.refresh--fsyncFrames :: FrontendSession -> IO ()-fsyncFrames _ = return ()---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame-  nextEvent--keyTranslate :: C.Key -> K.KM-keyTranslate e = (\(key, modifier) -> K.KM {..}) $-  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.KeyBackspace   -> (K.BackSpace, 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.KeyEnd         -> (K.End,     K.NoModifier)-    C.KeyPPage       -> (K.PgUp,    K.NoModifier)-    C.KeyNPage       -> (K.PgDn,    K.NoModifier)-    C.KeyBeg         -> (K.Begin,   K.NoModifier)-    C.KeyB2          -> (K.Begin,   K.NoModifier)-    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 leader picking,-        -- so disabling the latter and interpreting the keypad numbers-        -- as movement:-      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)-      | otherwise           -> (K.Char c,            K.NoModifier)-    _                       -> (K.Unknown (tshow 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
− Game/LambdaHack/Client/UI/Frontend/Gtk.hs 
@@ -1,464 +0,0 @@--- | Text frontend based on Gtk.-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-module Game.LambdaHack.Client.UI.Frontend.Gtk-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Exception as Ex hiding (handle)-import Control.Exception.Assert.Sugar-import Control.Monad-import Control.Monad.Reader-import qualified Data.ByteString.Char8 as BS-import Data.IORef-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Graphics.UI.Gtk hiding (Point)-import System.Time--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.LQueue--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-      }-  | 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.KM)                 -- ^ channel for keyboard input-  , sframeState :: !(MVar FrameState)-      -- ^ State of the frame finite machine. This mvar is locked-      -- for a short time only, because it's needed, among others,-      -- to display frames, which is done by a single polling thread,-      -- in real time.-  , slastFull   :: !(MVar (GtkFrame, Bool))-      -- ^ Most recent full (not empty, not repeated) frame received-      -- and if any empty frame followed it. This mvar is locked-      -- for longer intervals to ensure that threads (possibly many)-      -- add frames in an orderly manner. This is not done in real time,-      -- though sometimes the frame display subsystem has to poll-      -- for a frame, in which case the locking interval becomes meaningful.-  , sescMVar    :: !(Maybe (MVar ()))-  , sdebugCli   :: !DebugModeCli  -- ^ client configuration-  }--data GtkFrame = GtkFrame-  { gfChar :: !BS.ByteString-  , gfAttr :: ![[TextTag]]-  }-  deriving Eq--dummyFrame :: GtkFrame-dummyFrame = GtkFrame BS.empty []---- | Perform an operation on the frame queue.-onQueue :: (LQueue (Maybe GtkFrame) -> LQueue (Maybe GtkFrame))-        -> FrontendSession -> IO ()-onQueue f FrontendSession{sframeState} = do-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      putMVar sframeState FPushed{fpushed = f fpushed, ..}-    _ ->-      putMVar sframeState fs---- | The name of the frontend.-frontendName :: String-frontendName = "gtk"---- | Starts GTK. The other threads have to be spawned--- after gtk is initialized, because they call @postGUIAsync@,--- and need @sview@ and @stags@. Because of Windows, GTK needs to be--- on a bound thread, so we can't avoid the communication overhead--- of bound threads, so there's no point spawning a separate thread for GTK.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup = runGtk---- | Sets up and starts the main GTK loop providing input and output.-runGtk :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-runGtk sdebugCli@DebugModeCli{sfont} cont = 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 <- newMVar (dummyFrame, False)-  escMVar <- newEmptyMVar-  let sess = FrontendSession{sescMVar = Just escMVar, ..}-  -- Fork the game logic thread. When logic ends, game exits.-  -- TODO: is postGUISync needed here?-  aCont <- async $ cont sess `Ex.finally` postGUISync mainQuit-  link aCont-  -- Fork the thread that periodically draws a frame from a queue, if any.-  aPoll <- async $ pollFramesAct sess `Ex.finally` postGUISync mainQuit-  link aPoll-  -- 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-        -- If ESC, also mark it specially.-        when (key == K.Esc) $-          void $ tryPutMVar escMVar ()-        -- Store the key in the channel.-        writeChan schanKey K.KM{key, modifier}-      return True-  -- Set the font specified in config, if any.-  f <- fontDescriptionFromString $ fromMaybe "" sfont-  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-  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 = zip [0..] gfAttr-      defAttr = stags M.! Color.defAttr-  textBufferSetByteString tb gfChar-  mapM_ (setTo tb defAttr 0) attrs--setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO ()-setTo _ _ _ (_,  []) = return ()-setTo tb defAttr lx (ly, attr:attrs) = do-  ib <- textBufferGetIterAtLineOffset tb ly lx-  ie <- textIterCopy ib-  let setIter :: TextTag -> Int -> [TextTag] -> IO ()-      setIter previous repetitions [] = do-        textIterForwardChars ie repetitions-        when (previous /= defAttr) $-          textBufferApplyTag tb previous ib ie-      setIter previous repetitions (a:as)-        | a == previous =-            setIter a (repetitions + 1) as-        | otherwise = do-            textIterForwardChars ie repetitions-            when (previous /= defAttr) $-              textBufferApplyTag tb previous ib ie-            textIterForwardChars ib repetitions-            setIter a 1 as-  setIter attr 1 attrs---- | Maximal polls per second.-maxPolls :: Int -> Int-maxPolls maxFps = max 120 (2 * maxFps)--picoInMicro :: Int-picoInMicro = 1000000---- | Add a given number of microseconds to time.-addTime :: ClockTime -> Int -> ClockTime-addTime (TOD s p) mus = TOD s (p + fromIntegral (mus * picoInMicro))---- | The difference between the first and the second time, in microseconds.-diffTime :: ClockTime -> ClockTime -> Int-diffTime (TOD s1 p1) (TOD s2 p2) =-  fromIntegral (s1 - s2) * picoInMicro +-  fromIntegral (p1 - p2) `div` picoInMicro--microInSec :: Int-microInSec = 1000000--defaultMaxFps :: Int-defaultMaxFps = 15---- | Poll the frame queue often and draw frames at fixed intervals.-pollFramesWait :: FrontendSession -> ClockTime -> IO ()-pollFramesWait sess@FrontendSession{sdebugCli=DebugModeCli{smaxFps}}-               setTime = do-  -- Check if the time is up.-  let maxFps = fromMaybe defaultMaxFps smaxFps-  curTime <- getClockTime-  let diffSetCur = diffTime setTime curTime-  if diffSetCur > microInSec `div` maxPolls maxFps-    then do-      -- Delay half of the time difference.-      threadDelay $ diffTime curTime setTime `div` 2-      pollFramesWait sess setTime-    else-      -- Don't delay, because time is up!-      pollFramesAct sess---- | Poll the frame queue often and draw frames at fixed intervals.-pollFramesAct :: FrontendSession -> IO ()-pollFramesAct sess@FrontendSession{sframeState, sdebugCli=DebugModeCli{..}} = do-  -- Time is up, check if we actually wait for anyting.-  let maxFps = fromMaybe defaultMaxFps smaxFps-  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}-          -- Count the time spent outputting towards the total frame time.-          curTime <- getClockTime-          -- Wait until the frame is drawn.-          postGUISync $ output sess frame-          -- Regardless of how much time drawing took, wait at least-          -- half of the normal delay time. This can distort the large-scale-          -- frame rhythm, but makes sure this frame can at all be seen.-          -- If the main GTK thread doesn't lag, large-scale rhythm will be OK.-          -- TODO: anyway, it's GC that causes visible snags, most probably.-          threadDelay $ microInSec `div` (maxFps * 2)-          pollFramesWait sess $ addTime curTime $ microInSec `div` maxFps-        Just (Nothing, queue) -> do-          -- Delay requested via an empty frame.-          putMVar sframeState FPushed{fpushed = queue, ..}-          unless snoDelay $-            -- There is no problem if the delay is a bit delayed.-            threadDelay $ microInSec `div` maxFps-          pollFramesAct sess-        Nothing -> do-          -- The queue is empty, the game logic thread lags.-          putMVar sframeState fs-          -- Time is up, the game thread is going to send a frame,-          -- (otherwise it would change the state), so poll often.-          threadDelay $ microInSec `div` maxPolls maxFps-          pollFramesAct sess-    _ -> 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 $ microInSec `div` (maxFps * 2)-      pollFramesAct sess---- | Add a game screen frame to the frame drawing channel, or show--- it ASAP if @immediate@ display is requested and the channel is empty.-pushFrame :: FrontendSession -> Bool -> Bool -> Maybe SingleFrame -> IO ()-pushFrame sess noDelay immediate rawFrame = do-  let FrontendSession{sframeState, slastFull} = sess-  -- Full evaluation is done outside the mvar locks.-  let !frame = case rawFrame of-        Nothing -> Nothing-        Just fr -> Just $! evalFrame sess fr-  -- Lock frame addition.-  (lastFrame, anyFollowed) <- takeMVar slastFull-  -- Comparison of frames is done outside the frame queue mvar lock.-  let nextFrame = if frame == Just lastFrame-                  then Nothing  -- no sense repeating-                  else frame-  -- Lock frame queue.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      putMVar sframeState-      $ if isNothing nextFrame && anyFollowed-        then fs  -- old news-        else FPushed{fpushed = writeLQueue fpushed nextFrame, ..}-    FNone | immediate -> do-      -- If the frame not repeated, draw it.-      maybe skip (postGUIAsync . output sess) nextFrame-      -- Frame sent, we may now safely release the queue lock.-      putMVar sframeState FNone-    FNone ->-      -- Never start playing with an empty frame.-      let fpushed = if isJust nextFrame-                    then writeLQueue newLQueue nextFrame-                    else newLQueue-          fshown = dummyFrame-      in putMVar sframeState FPushed{..}-  case nextFrame of-    Nothing -> putMVar slastFull (lastFrame, True)-    Just f  -> putMVar slastFull (f, noDelay)--evalFrame :: FrontendSession -> SingleFrame -> GtkFrame-evalFrame FrontendSession{stags} rawSF =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      sfLevelDecoded = map decodeLine sfLevel-      levelChar = unlines $ map (map Color.acChar) sfLevelDecoded-      gfChar = BS.pack $ init levelChar-      -- Strict version of @map (map ((stags M.!) . fst)) sfLevelDecoded@.-      gfAttr  = reverse $ foldl' ff [] sfLevelDecoded-      ff ll l = reverse (foldl' f [] l) : ll-      f l ac  = let !tag = stags M.! Color.acAttr ac in tag : l-  in GtkFrame{..}---- | Trim current frame queue and display the most recent frame, if any.-trimFrameState :: FrontendSession -> IO ()-trimFrameState sess@FrontendSession{sframeState} = do-  -- Take the lock to wipe out the frame queue, unless it's empty already.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      -- Remove all but the last element of the frame queue.-      -- The kept (and displayed) last element ensures that-      -- @slastFull@ is not invalidated.-      case lastLQueue fpushed of-        Just frame -> do-          -- Comparison is done inside the mvar lock, this time, but it's OK,-          -- since we wipe out the queue anyway, not draw it concurrently.-          let lastFrame = fshown-              nextFrame = if frame == lastFrame-                          then Nothing  -- no sense repeating-                          else Just frame-          -- Draw the last frame ASAP.-          maybe skip (postGUIAsync . output sess) nextFrame-        Nothing -> return ()-    FNone -> return ()-  -- Wipe out the frame queue. Release the lock.-  putMVar sframeState FNone---- | Add a frame to be drawn.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay sess noDelay = pushFrame sess noDelay False---- Display all queued frames, synchronously.-displayAllFramesSync :: FrontendSession -> FrameState -> IO ()-displayAllFramesSync sess@FrontendSession{sdebugCli=DebugModeCli{..}} fs = do-  let maxFps = fromMaybe defaultMaxFps smaxFps-  case fs of-    FPushed{..} ->-      case tryReadLQueue fpushed of-        Just (Just frame, queue) -> do-          -- Display synchronously.-          postGUISync $ output sess frame-          threadDelay $ microInSec `div` maxFps-          displayAllFramesSync sess FPushed{fpushed = queue, fshown = frame}-        Just (Nothing, queue) -> do-          -- Delay requested via an empty frame.-          unless snoDelay $-            threadDelay $ microInSec `div` maxFps-          displayAllFramesSync sess FPushed{fpushed = queue, ..}-        Nothing ->-          -- The queue is empty.-          return ()-    _ ->-      -- Not in Push state to start with.-      return ()--fsyncFrames :: FrontendSession -> IO ()-fsyncFrames sess@FrontendSession{sframeState} = do-  fs <- takeMVar sframeState-  displayAllFramesSync sess fs-  putMVar sframeState FNone---- | Display a prompt, wait for any key.--- Starts in Push mode, ends in Push or None mode.--- Syncs with the drawing threads by showing the last or all queued frames.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess@FrontendSession{..}-              frame = do-  pushFrame sess True True $ Just frame-  km <- readChan schanKey-  case km of-    K.KM{key=K.Space} ->-      -- Drop frames up to the first empty frame.-      -- Keep the last non-empty frame, if any.-      -- Pressing SPACE repeatedly can be used to step-      -- through intermediate stages of an animation,-      -- whereas any other key skips the whole animation outright.-      onQueue dropStartLQueue sess-    _ ->-      -- Show the last non-empty frame and empty the queue.-      trimFrameState sess-  return km---- | Tells a dead key.-deadKey :: String -> Bool-deadKey x = case x of-  "Shift_L"          -> True-  "Shift_R"          -> 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.defAttr = 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]
− Game/LambdaHack/Client/UI/Frontend/Std.hs 
@@ -1,84 +0,0 @@--- | Text frontend based on stdin/stdout, intended for bots.-module Game.LambdaHack.Client.UI.Frontend.Std-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Exception as Ex hiding (handle)-import qualified Data.ByteString.Char8 as BS-import Data.Char (chr, ord)-import qualified System.IO as SIO--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color---- | No session data needs to be maintained by this frontend.-data FrontendSession = FrontendSession-  { sdebugCli :: !DebugModeCli  -- ^ client configuration-  , sescMVar  :: !(Maybe (MVar ()))-  }---- | The name of the frontend.-frontendName :: String-frontendName = "std"---- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do-  a <- async $ k FrontendSession{sescMVar = Nothing, ..}-               `Ex.finally` (SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr)-  wait a---- | Output to the screen via the frontend.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay _ _ Nothing = return ()-fdisplay _ _ (Just rawSF) =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty]-  in mapM_ BS.putStrLn bs---- | Input key via the frontend.-nextEvent :: IO K.KM-nextEvent = do-  l <- BS.hGetLine SIO.stdin-  let c = case BS.uncons l of-        Nothing -> '\n'  -- empty line counts as RET-        Just (hd, _) -> hd-  return $! keyTranslate c--fsyncFrames :: FrontendSession -> IO ()-fsyncFrames _ = return ()---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame-  nextEvent--keyTranslate :: Char -> K.KM-keyTranslate e = (\(key, modifier) -> K.KM {..}) $-  case e of-    '\ESC' -> (K.Esc,     K.NoModifier)-    '\n'   -> (K.Return,  K.NoModifier)-    '\r'   -> (K.Return,  K.NoModifier)-    ' '    -> (K.Space,   K.NoModifier)-    '\t'   -> (K.Tab,     K.NoModifier)-    c | ord '\^A' <= ord c && ord c <= ord '\^Z' ->-        -- Alas, only lower-case letters.-        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)-        -- Movement keys are more important than leader picking,-        -- so disabling the latter and interpreting the keypad numbers-        -- as movement:-      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)-      | otherwise           -> (K.Char c,            K.NoModifier)
− Game/LambdaHack/Client/UI/Frontend/Vty.hs 
@@ -1,144 +0,0 @@--- | Text frontend based on Vty.-module Game.LambdaHack.Client.UI.Frontend.Vty-  ( -- * Session data type for the frontend-    FrontendSession(sescMVar)-    -- * The output and input operations-  , fdisplay, fpromptGetKey, fsyncFrames-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Exception as Ex hiding (handle)-import Graphics.Vty-import qualified Graphics.Vty as Vty--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Msg---- | Session data maintained by the frontend.-data FrontendSession = FrontendSession-  { svty      :: !Vty  -- internal vty session-  , sescMVar  :: !(Maybe (MVar ()))-  , sdebugCli :: !DebugModeCli  -- ^ client configuration-      -- ^ Configuration of the frontend session.-  }---- | The name of the frontend.-frontendName :: String-frontendName = "vty"---- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do-  svty <- mkVty-  -- TODO: implement sescMVar, when we switch to a new vty that has-  -- a separate key listener thread or something. Avoid polling.-  a <- async $ k FrontendSession{sescMVar = Nothing, ..}-               `Ex.finally` Vty.shutdown svty-  wait a---- | Output to the screen via the frontend.-fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool-         -> Maybe SingleFrame  -- ^ the screen frame to draw-         -> IO ()-fdisplay _ _ Nothing = return ()-fdisplay FrontendSession{svty} _ (Just rawSF) =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      img = (foldr (<->) empty_image-             . map (foldr (<|>) empty_image-                      . map (\ Color.AttrChar{..} ->-                                char (setAttr acAttr) acChar)))-            $ map decodeLine sfLevel-      pic = pic_for_image img-  in update svty pic---- | Input key via the frontend.-nextEvent :: FrontendSession -> IO K.KM-nextEvent sess@FrontendSession{svty} = do-  e <- next_event svty-  case e of-    EvKey n mods -> do-      let key = keyTranslate n-          modifier = modifierTranslate mods-      return $! K.KM {key, modifier}-    _ -> nextEvent sess--fsyncFrames :: FrontendSession -> IO ()-fsyncFrames _ = return ()---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame-  nextEvent sess---- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals--- so we should probably go back to using 0-9 (and Shift) for movement--- but let's wait until vty 5.0 is out and see if it helps.-keyTranslate :: Key -> K.Key-keyTranslate n =-  case n of-    KEsc          -> K.Esc-    KEnter        -> K.Return-    (KASCII ' ')  -> K.Space-    (KASCII '\t') -> K.Tab-    KBackTab      -> K.BackTab-    KBS           -> K.BackSpace-    KUp           -> K.Up-    KDown         -> K.Down-    KLeft         -> K.Left-    KRight        -> K.Right-    KHome         -> K.Home-    KEnd          -> K.End-    KPageUp       -> K.PgUp-    KPageDown     -> K.PgDn-    KBegin        -> K.Begin-    KNP5          -> K.Begin-    (KASCII c)    -> K.Char c-    _             -> K.Unknown (tshow n)---- | Translates modifiers to our own encoding.-modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods =-  if MCtrl `elem` mods then K.Control else K.NoModifier---- TODO: with vty 5.0 check if bold is still needed.--- A hack to get bright colors via the bold attribute. Depending on terminal--- settings this is needed or not and the characters really get bold or not.--- HSCurses does this by default, but in Vty you have to request the hack.-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.defAttr---  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
− Game/LambdaHack/Client/UI/HandleHumanClient.hs 
@@ -1,86 +0,0 @@--- | Semantics of human player commands.-module Game.LambdaHack.Client.UI.HandleHumanClient-  ( cmdHumanSem-  ) where--import Control.Applicative-import Data.Monoid--import Game.LambdaHack.Client.UI.HandleHumanGlobalClient-import Game.LambdaHack.Client.UI.HandleHumanLocalClient-import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Common.Request---- | The semantics of human player commands in terms of the @Action@ monad.--- Decides if the action takes time and what action to perform.--- Some time cosuming commands are enabled in targeting mode, but cannot be--- invoked in targeting mode on a remote level (level different than--- the level of the leader).-cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI)-cmdHumanSem cmd = do-  if noRemoteHumanCmd cmd then do-    -- If in targeting mode, check if the current level is the same-    -- as player level and refuse performing the action otherwise.-    arena <- getArenaUI-    lidV <- viewedLevel-    if (arena /= lidV) then-      failWith $ "command disabled on a remote level, press ESC to switch back"-    else cmdAction cmd-  else cmdAction cmd---- | Compute the basic action for a command and mark whether it takes time.-cmdAction :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI)-cmdAction cmd = case cmd of-  -- Global.-  Move v -> fmap anyToUI <$> moveRunHuman False v-  Run v -> fmap anyToUI <$> moveRunHuman True v-  Wait -> Right <$> fmap ReqUITimed waitHuman-  MoveItem cLegalRaw toCStore verbRaw _ auto ->-    fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore verbRaw auto-  Project ts -> fmap ReqUITimed <$> projectHuman ts-  Apply ts -> fmap ReqUITimed <$> applyHuman ts-  AlterDir ts -> fmap ReqUITimed <$> alterDirHuman ts-  TriggerTile ts -> fmap ReqUITimed <$> triggerTileHuman ts-  StepToTarget -> fmap anyToUI <$> stepToTargetHuman--  GameRestart t -> gameRestartHuman t-  GameExit -> gameExitHuman-  GameSave -> fmap Right gameSaveHuman-  Automate -> automateHuman--  -- Local.-  GameDifficultyCycle -> addNoSlides gameDifficultyCycle-  PickLeader k -> Left <$> pickLeaderHuman k-  MemberCycle -> Left <$> memberCycleHuman-  MemberBack -> Left <$> memberBackHuman-  DescribeItem cstore -> Left <$> describeItemHuman cstore-  AllOwned -> Left <$> allOwnedHuman-  SelectActor -> Left <$> selectActorHuman-  SelectNone -> addNoSlides selectNoneHuman-  Clear -> addNoSlides clearHuman-  Repeat n -> addNoSlides $ repeatHuman n-  Record -> Left <$> recordHuman-  History -> Left <$> historyHuman-  MarkVision -> addNoSlides markVisionHuman-  MarkSmell -> addNoSlides markSmellHuman-  MarkSuspect -> addNoSlides markSuspectHuman-  Help -> Left <$> helpHuman-  MainMenu -> Left <$> mainMenuHuman-  Macro _ kms -> addNoSlides $ macroHuman kms--  MoveCursor v k -> Left <$> moveCursorHuman v k-  TgtFloor -> Left <$> tgtFloorHuman-  TgtEnemy -> Left <$> tgtEnemyHuman-  TgtUnknown -> Left <$> tgtUnknownHuman-  TgtItem -> Left <$> tgtItemHuman-  TgtStair up -> Left <$> tgtStairHuman up-  TgtAscend k -> Left <$> tgtAscendHuman k-  EpsIncr b -> Left <$> epsIncrHuman b-  TgtClear -> Left <$> tgtClearHuman-  Cancel -> Left <$> cancelHuman mainMenuHuman-  Accept -> Left <$> acceptHuman helpHuman--addNoSlides :: Monad m => m () -> m (SlideOrCmd RequestUI)-addNoSlides cmdCli = cmdCli >> return (Left mempty)
− Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs 
@@ -1,576 +0,0 @@-{-# LANGUAGE DataKinds #-}--- | Semantics of 'Command.Cmd' client commands that return server commands.--- A couple of them do not take time, the rest does.--- TODO: document-module Game.LambdaHack.Client.UI.HandleHumanGlobalClient-  ( -- * Commands that usually take time-    moveRunHuman, waitHuman, moveItemHuman-  , projectHuman, applyHuman, alterDirHuman, triggerTileHuman-  , stepToTargetHuman-    -- * Commands that never take time-  , gameRestartHuman, gameExitHuman, gameSaveHuman, automateHuman-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.HandleHumanLocalClient-import Game.LambdaHack.Client.UI.HumanCmd (Trigger (..))-import Game.LambdaHack.Client.UI.InventoryClient-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.RunClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind---- * Move and Run--moveRunHuman :: MonadClientUI m-             => Bool -> Vector -> m (SlideOrCmd RequestAnyAbility)-moveRunHuman run dir = do-  tgtMode <- getsClient stgtMode-  if isJust tgtMode then-    fmap Left $ moveCursorHuman dir (if run then 10 else 1)-  else do-    arena <- getArenaUI-    leader <- getLeaderUI-    sb <- getsState $ getActorBody leader-    fact <- getsState $ (EM.! bfid sb) . sfactionD-    let tpos = bpos sb `shift` dir-    -- We start by checking actors at the the target position,-    -- which gives a partial information (actors can be invisible),-    -- as opposed to accessibility (and items) which are always accurate-    -- (tiles can't be invisible).-    tgts <- getsState $ posToActors tpos arena-    case tgts of-      [] -> do  -- move or search or alter-        -- Start running in the given direction. The first turn of running-        -- succeeds much more often than subsequent turns, because we ignore-        -- most of the disturbances, since the player is mostly aware of them-        -- and still explicitly requests a run, knowing how it behaves.-        runStopOrCmd <- moveRunAid leader dir-        case runStopOrCmd of-          Left stopMsg -> failWith stopMsg-          Right runCmd -> do-            cops <- getsState scops-            sel <- getsClient sselected-            let runMembers = if isAllMoveFact cops fact-                             then [leader]  -- TODO: warn?-                             else ES.toList (ES.delete leader sel) ++ [leader]-                runParams = RunParams { runLeader = leader-                                      , runMembers-                                      , runDist = 0-                                      , runStopMsg = Nothing-                                      , runInitDir = Just dir }-            when run $ modifyClient $ \cli -> cli {srunning = Just runParams}-            return $ Right runCmd-        -- When running, the invisible actor is hit (not displaced!),-        -- so that running in the presence of roving invisible-        -- actors is equivalent to moving (with visible actors-        -- this is not a problem, since runnning stops early enough).-        -- TODO: stop running at invisible actor-      [((target, _), _)] | run ->-        -- Displacing requires accessibility, but it's checked later on.-        fmap RequestAnyAbility <$> displaceAid target-      _ : _ : _ | run -> do-        assert (all (bproj . snd . fst) tgts) skip-        failSer DisplaceProjectiles-      ((target, tb), _) : _ -> do-        -- No problem if there are many projectiles at the spot. We just-        -- attack the first one.-        -- We always see actors from our own faction.-        if bfid tb == bfid sb && not (bproj tb) then do-          cops <- getsState scops-          if isAllMoveFact cops fact then failWith msgCannotChangeLeader-          else do-            -- Select adjacent actor by bumping into him. Takes no time.-            success <- pickLeader True target-            assert (success `blame` "bump self"-                            `twith` (leader, target, tb)) skip-            return $ Left mempty-        else-          -- Attacking does not require full access, adjacency is enough.-          fmap RequestAnyAbility <$> meleeAid target---- | Actor atttacks an enemy actor or his own projectile.-meleeAid :: MonadClientUI m-         => ActorId -> m (SlideOrCmd (RequestTimed AbMelee))-meleeAid target = do-  leader <- getLeaderUI-  sb <- getsState $ getActorBody leader-  tb <- getsState $ getActorBody target-  sfact <- getsState $ (EM.! bfid sb) . sfactionD-  mel <- pickWeaponClient leader target-  case mel of-    [] -> failWith "nothing to melee with"-    wp : _ -> do-      let returnCmd = return $ Right wp-          res | bproj tb || isAtWar sfact (bfid tb) = returnCmd-              | isAllied sfact (bfid tb) = do-                go1 <- displayYesNo ColorBW-                         "You are bound by an alliance. Really attack?"-                if not go1 then failWith "Attack canceled." else returnCmd-              | otherwise = do-                go2 <- displayYesNo ColorBW-                         "This attack will start a war. Are you sure?"-                if not go2 then failWith "Attack canceled." else returnCmd-      res-  -- Seeing the actor prevents altering a tile under it, but that-  -- does not limit the player, he just doesn't waste a turn-  -- on a failed altering.---- | Actor swaps position with another.-displaceAid :: MonadClientUI m-            => ActorId -> m (SlideOrCmd (RequestTimed AbDisplace))-displaceAid target = do-  cops <- getsState scops-  leader <- getLeaderUI-  sb <- getsState $ getActorBody leader-  tb <- getsState $ getActorBody target-  tfact <- getsState $ (EM.! bfid tb) . sfactionD-  activeItems <- activeItemsClient target-  disp <- getsState $ dispEnemy leader target activeItems-  let spos = bpos sb-      tpos = bpos tb-      adj = checkAdjacent sb tb-      atWar = isAtWar tfact (bfid sb)-  if not adj then failSer DisplaceDistant-  else if not (bproj tb) && atWar-          && actorDying tb then failSer DisplaceDying-  else if not (bproj tb) && atWar-          && braced tb then failSer DisplaceBraced-  else if not disp && atWar then failSer DisplaceSupported-  else do-    let lid = blid sb-    lvl <- getLevel lid-    -- Displacing requires full access.-    if accessible cops lvl spos tpos then do-      tgts <- getsState $ posToActors tpos lid-      case tgts of-        [] -> assert `failure` (leader, sb, target, tb)-        [_] -> do-          return $ Right $ ReqDisplace target-        _ -> failSer DisplaceProjectiles-    else failSer DisplaceAccess---- * Wait---- | Leader waits a turn (and blocks, etc.).-waitHuman :: MonadClientUI m => m (RequestTimed AbWait)-waitHuman = do-  modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}-  return ReqWait---- * MoveItem--moveItemHuman :: MonadClientUI m-              => [CStore] -> CStore -> Text -> Bool-              -> m (SlideOrCmd (RequestTimed AbMoveItem))-moveItemHuman cLegalRaw destCStore verbRaw auto = do-  assert (destCStore `notElem` cLegalRaw) skip-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  activeItems <- activeItemsClient leader-  let cLegal = if calmEnough b activeItems-               then cLegalRaw-               else if destCStore == CSha-                    then []-                    else delete CSha cLegalRaw-      verb = MU.Text verbRaw-  ggi <- if auto-         then getAnyItem verb cLegalRaw cLegal False False-         else getAnyItem verb cLegalRaw cLegal True True-  case ggi of-    Right ((iid, itemFull), CActor _ fromCStore) -> do-      let k = itemK itemFull-          msgAndSer toCStore = do-            subject <- partAidLeader leader-            msgAdd $ makeSentence-              [ MU.SubjectVerbSg subject verb, partItemWs k toCStore itemFull ]-            return $ Right $ ReqMoveItem iid k fromCStore toCStore-      if fromCStore == CGround-      then case destCStore of-        CEqp | goesIntoInv (itemBase itemFull) -> do-          updateItemSlot (Just leader) iid  -- slot not yet assigned-          msgAndSer CInv-        CEqp | eqpOverfull b k -> do-          msgAdd $ "Warning:" <+> showReqFailure EqpOverfull-          updateItemSlot (Just leader) iid  -- slot not yet assigned-          msgAndSer CInv-        _ -> msgAndSer destCStore-      else case destCStore of-        CEqp | eqpOverfull b k -> failSer EqpOverfull-        _ -> msgAndSer destCStore-    Left slides -> return $ Left slides-    _ -> assert `failure` ggi---- * Project--projectHuman :: MonadClientUI m-             => [Trigger] -> m (SlideOrCmd (RequestTimed AbProject))-projectHuman ts = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  tgtPos <- leaderTgtToPos-  tgt <- getsClient $ getTarget leader-  case tgtPos of-    Nothing -> failWith "last target invalid"-    Just pos | pos == bpos b -> failWith "cannot aim at oneself"-    Just pos -> do-      -- Set cursor to the personal target, temporarily.-      oldCursor <- getsClient scursor-      modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt}-      -- Show the targeting line, temporarily.-      oldTgtMode <- getsClient stgtMode-      lidV <- viewedLevel-      modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV}-      canAim <- leaderTgtAims-      oldEps <- getsClient seps-      outcome <- case canAim of-        Right newEps -> do-          -- Modify @seps@,, temporarily.-          modifyClient $ \cli -> cli {seps = newEps}-          projectPos ts pos-        Left cause -> failWith cause-      modifyClient $ \cli -> cli { stgtMode = oldTgtMode-                                 , scursor = oldCursor-                                 , seps = oldEps }-      return outcome--projectPos :: MonadClientUI m-           => [Trigger] -> Point -> m (SlideOrCmd (RequestTimed AbProject))-projectPos ts tpos = do-  Kind.COps{cotile} <- getsState scops-  leader <- getLeaderUI-  eps <- getsClient seps-  sb <- getsState $ getActorBody leader-  let lid = blid sb-      spos = bpos sb-  Level{lxsize, lysize} <- getLevel lid-  do-      case bla lxsize lysize eps spos tpos of-        Nothing -> failSer ProjectAimOnself-        Just [] -> assert `failure` "project from the edge of level"-                          `twith` (spos, tpos, sb, ts)-        Just (pos : _) -> do-          lvl <- getLevel lid-          let t = lvl `at` pos-          if not $ Tile.isWalkable cotile t-            then failSer ProjectBlockTerrain-            else do-              actorBlind <--                radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight leader-              mab <- getsState $ posToActor pos lid-              if maybe True (bproj . snd . fst) mab-              then if actorBlind-                   then failSer ProjectBlind-                   else projectEps ts tpos eps-              else failSer ProjectBlockActor--projectEps :: MonadClientUI m-           => [Trigger] -> Point -> Int-           -> m (SlideOrCmd (RequestTimed AbProject))-projectEps ts tpos eps = do-  leader <- getLeaderUI-  sb <- getsState $ getActorBody leader-  let cLegal = [CGround, CInv, CEqp]-      (verb1, object1) = case ts of-        [] -> ("aim", "item")-        tr : _ -> (verb tr, object tr)-      triggerSyms = triggerSymbols ts-      p item =-        let goodKind = if ' ' `elem` triggerSyms-                       then case strengthEqpSlot item of-                         Just (Effect.EqpSlotAddLight, _) -> True-                         Just _ -> False-                         Nothing -> True-                       else jsymbol item `elem` triggerSyms-            trange = totalRange item-        in goodKind-           && trange >= chessDist (bpos sb) tpos-  ggi <- getGroupItem p object1 verb1 cLegal cLegal-  case ggi of-    Right ((iid, _), CActor _ fromCStore) -> do-      return $ Right $ ReqProject tpos eps iid fromCStore-    Left slides -> return $ Left slides-    _ -> assert `failure` ggi--triggerSymbols :: [Trigger] -> [Char]-triggerSymbols [] = []-triggerSymbols (ApplyItem{symbol} : ts) = symbol : triggerSymbols ts-triggerSymbols (_ : ts) = triggerSymbols ts---- * Apply--applyHuman :: MonadClientUI m-           => [Trigger] -> m (SlideOrCmd (RequestTimed AbApply))-applyHuman ts = do-  leader <- getLeaderUI-  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight leader-  let cLegal = [CGround, CInv, CEqp]-      (verb1, object1) = case ts of-        [] -> ("activate", "item")-        tr : _ -> (verb tr, object tr)-      triggerSyms = triggerSymbols ts-      blindScroll item = jsymbol item == '?' && actorBlind-      p item = not (blindScroll item)-               && if ' ' `elem` triggerSyms-                  then Effect.Applicable `elem` jfeature item-                  else jsymbol item `elem` triggerSyms-  ggi <- getGroupItem p object1 verb1 cLegal cLegal-  case ggi of-    Right ((iid, itemFull), CActor _ fromCStore) -> do-      let durable = Effect.Durable `elem` jfeature (itemBase itemFull)-          periodic = isJust-                     $ strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull-      if durable && periodic-        then failSer DurablePeriodicAbuse-        else if (blindScroll $ itemBase itemFull)-             then failSer ApplyBlind-             else return $ Right $ ReqApply iid fromCStore-    Left slides -> return $ Left slides-    _ -> assert `failure` ggi---- * AlterDir---- | Ask for a direction and alter a tile, if possible.-alterDirHuman :: MonadClientUI m-              => [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter))-alterDirHuman ts = do-  Config{configVi, configLaptop} <- askConfig-  let verb1 = case ts of-        [] -> "alter"-        tr : _ -> verb tr-      keys = zipWith K.KM (repeat K.NoModifier)-                          (K.dirAllKey configVi configLaptop)-      prompt = makePhrase ["What to", verb1 MU.:> "? [movement key"]-  me <- displayChoiceUI prompt emptyOverlay keys-  case me of-    Left slides -> failSlides slides-    Right e -> K.handleDir configVi configLaptop e (flip alterTile ts)-                                                   (failWith "never mind")---- | Player tries to alter a tile using a feature.-alterTile :: MonadClientUI m-          => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter))-alterTile dir ts = do-  Kind.COps{cotile} <- getsState scops-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  lvl <- getLevel $ blid b-  let tpos = bpos b `shift` dir-      t = lvl `at` tpos-      alterFeats = alterFeatures ts-  case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of-    [] -> failWith $ guessAlter cotile alterFeats t-    feat : _ -> return $ Right $ ReqAlter tpos $ Just feat--alterFeatures :: [Trigger] -> [F.Feature]-alterFeatures [] = []-alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts-alterFeatures (_ : ts) = alterFeatures ts---- | Guess and report why the bump command failed.-guessAlter :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg-guessAlter cotile (F.OpenTo _ : _) t-  | Tile.isClosable cotile t = "already open"-guessAlter _ (F.OpenTo _ : _) _ = "cannot be opened"-guessAlter cotile (F.CloseTo _ : _) t-  | Tile.isOpenable cotile t = "already closed"-guessAlter _ (F.CloseTo _ : _) _ = "cannot be closed"-guessAlter _ _ _ = "never mind"---- * TriggerTile---- | Leader tries to trigger the tile he's standing on.-triggerTileHuman :: MonadClientUI m-                 => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger))-triggerTileHuman ts = do-  tgtMode <- getsClient stgtMode-  if isJust tgtMode then do-    let getK tfs = case tfs of-          TriggerFeature {feature = F.Cause (Effect.Ascend k)} : _ -> Just k-          _ : rest -> getK rest-          [] -> Nothing-        mk = getK ts-    case mk of-      Nothing -> failWith  "never mind"-      Just k -> fmap Left $ tgtAscendHuman k-  else triggerTile ts---- | Player tries to trigger a tile using a feature.-triggerTile :: MonadClientUI m-            => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger))-triggerTile ts = do-  Kind.COps{cotile} <- getsState scops-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  lvl <- getLevel $ blid b-  let t = lvl `at` bpos b-      triggerFeats = triggerFeatures ts-  case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of-    [] -> failWith $ guessTrigger cotile triggerFeats t-    feat : _ -> do-      go <- verifyTrigger leader feat-      case go of-        Right () -> return $ Right $ ReqTrigger $ Just feat-        Left slides -> return $ Left slides--triggerFeatures :: [Trigger] -> [F.Feature]-triggerFeatures [] = []-triggerFeatures (TriggerFeature{feature} : ts) = feature : triggerFeatures ts-triggerFeatures (_ : ts) = triggerFeatures ts---- | Verify important feature triggers, such as fleeing the dungeon.-verifyTrigger :: MonadClientUI m-              => ActorId -> F.Feature -> m (SlideOrCmd ())-verifyTrigger leader feat = case feat of-  F.Cause Effect.Escape{} -> do-    b <- getsState $ getActorBody leader-    side <- getsClient sside-    fact <- getsState $ (EM.! side) . sfactionD-    if isSpawnFact fact then failWith-      "This is the way out, but where would you go in this alien world?"-    else do-      go <- displayYesNo ColorFull "This is the way out. Really leave now?"-      if not go then failWith "Game resumed."-      else do-        (_, total) <- getsState $ calculateTotal b-        if total == 0 then do-          -- The player can back off at each of these steps.-          go1 <- displayMore ColorBW-                   "Afraid of the challenge? Leaving so soon and empty-handed?"-          if not go1 then failWith "Brave soul!"-          else do-             go2 <- displayMore ColorBW-                     "Next time try to grab some loot before escape!"-             if not go2 then failWith "Here's your chance!"-             else return $ Right ()-        else return $ Right ()-  _ -> return $ Right ()---- | Guess and report why the bump command failed.-guessTrigger :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg-guessTrigger cotile fs@(F.Cause (Effect.Ascend k) : _) t-  | Tile.hasFeature cotile (F.Cause (Effect.Ascend (-k))) t =-    if k > 0 then "the way goes down, not up"-    else if k < 0 then "the way goes up, not down"-    else assert `failure` fs-guessTrigger _ fs@(F.Cause (Effect.Ascend k) : _) _ =-    if k > 0 then "cannot ascend"-    else if k < 0 then "cannot descend"-    else assert `failure` fs-guessTrigger _ _ _ = "never mind"---- * StepToTarget--stepToTargetHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)-stepToTargetHuman = do-  tgtMode <- getsClient stgtMode-  -- Movement is legal only outside targeting mode.-  -- TODO: use this command for something in targeting mode.-  if isJust tgtMode then failWith "cannot move in targeting mode"-  else do-    leader <- getLeaderUI-    b <- getsState $ getActorBody leader-    tgtPos <- leaderTgtToPos-    case tgtPos of-      Nothing -> failWith "target not set"-      Just c | c == bpos b -> failWith "target reached"-      Just c -> do-        (_, mpath) <- getCacheBfsAndPath leader c-        case mpath of-          Nothing -> failWith "no route to target"-          Just [] -> assert `failure` (leader, b, bpos b, c)-          Just (p1 : _) -> do-            as <- getsState $ posToActors p1 (blid b)-            if not $ null as then-              failWith "actor in the path to target"-            else-              moveRunHuman False $ towards (bpos b) p1---- * GameRestart; does not take time--gameRestartHuman :: MonadClientUI m => Text -> m (SlideOrCmd RequestUI)-gameRestartHuman t = do-  let msg = "You just requested a new" <+> t <+> "game."-  b1 <- displayMore ColorFull msg-  if not b1 then failWith "never mind"-  else do-    b2 <- displayYesNo ColorBW-            "Current progress will be lost! Really restart the game?"-    msg2 <- rndToAction $ oneOf-              [ "Yea, would be a pity to leave them all to die."-              , "Yea, a shame to get your own team stranded." ]-    if not b2 then failWith msg2-    else do-      leader <- getLeaderUI-      DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-      Config{configHeroNames} <- askConfig-      return $ Right $ ReqUIGameRestart leader t sdifficultyCli configHeroNames---- * GameExit; does not take time--gameExitHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)-gameExitHuman = do-  go <- displayYesNo ColorFull "Really save and exit?"-  if go then do-    leader <- getLeaderUI-    DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-    return $ Right $ ReqUIGameExit leader sdifficultyCli-  else failWith "Save and exit canceled."---- * GameSave; does not take time--gameSaveHuman :: MonadClientUI m => m RequestUI-gameSaveHuman = do-  -- TODO: do not save to history:-  msgAdd "Saving game backup."-  return ReqUIGameSave---- * Automate; does not take time--automateHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)-automateHuman = do-  -- BFS is not updated while automated, which would lead to corruption.-  modifyClient $ \cli -> cli {stgtMode = Nothing}-  -- TODO: do not save to history:-  go <- displayMore ColorBW "Ceding control to AI (ESC to regain)."-  if not go-    then failWith "Automation canceled."-    else return $ Right ReqUIAutomate
− Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs 
@@ -1,645 +0,0 @@--- | Semantics of 'HumanCmd' client commands that do not return--- server commands. None of such commands takes game time.--- TODO: document-module Game.LambdaHack.Client.UI.HandleHumanLocalClient-  ( -- * Assorted commands-    gameDifficultyCycle-  , pickLeaderHuman, memberCycleHuman, memberBackHuman-  , describeItemHuman, allOwnedHuman-  , selectActorHuman, selectNoneHuman, clearHuman, repeatHuman, recordHuman-  , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman-  , helpHuman, mainMenuHuman, macroHuman-    -- * Commands specific to targeting-  , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman-  , tgtUnknownHuman, tgtItemHuman, tgtStairHuman, tgtAscendHuman-  , epsIncrHuman, tgtClearHuman, cancelHuman, acceptHuman-  ) where---- Cabal-import qualified Paths_LambdaHack as Self (version)--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import Data.Ord-import qualified Data.Text as T-import Data.Version-import Game.LambdaHack.Client.UI.Frontend (frontendName)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd-import Game.LambdaHack.Client.UI.InventoryClient-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind---- * GameDifficultyCycle--gameDifficultyCycle :: MonadClientUI m => m ()-gameDifficultyCycle = do-  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-  let d = if sdifficultyCli >= difficultyBound then 1 else sdifficultyCli + 1-  modifyClient $ \cli -> cli {sdebugCli = (sdebugCli cli) {sdifficultyCli = d}}-  msgAdd $ "Next game difficulty set to" <+> tshow d <> "."---- * PickLeader--pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow-pickLeaderHuman k = do-  cops <- getsState scops-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  s <- getState-  case tryFindHeroK s side k of-    _ | isAllMoveFact cops fact -> failMsg msgCannotChangeLeader-    Nothing -> failMsg "No such member of the party."-    Just (aid, _) -> do-      void $ pickLeader True aid-      return mempty---- * MemberCycle---- | Switches current member to the next on the level, if any, wrapping.-memberCycleHuman :: MonadClientUI m => m Slideshow-memberCycleHuman = memberCycle True---- * MemberBack---- | Switches current member to the previous in the whole dungeon, wrapping.-memberBackHuman :: MonadClientUI m => m Slideshow-memberBackHuman = memberBack True---- * DescribeItem---- | Display items from a given container store and describe the chosen one.-describeItemHuman :: MonadClientUI m => CStore -> m Slideshow-describeItemHuman cstore = do-  leader <- getLeaderUI-  describeItemC $ CActor leader cstore--describeItemC :: MonadClientUI m => Container -> m Slideshow-describeItemC c = do-  let subject body = partActor body-      verbSha body activeItems = if calmEnough body activeItems-                                 then "notice"-                                 else "paw distractedly"-      shaBlurb body activeItems = makePhrase-        [MU.Capitalize-         $ MU.SubjectVerbSg (subject body) (verbSha body activeItems)]-      stdBlurb body = makePhrase-        [MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"]-  itemToF <- itemToFullClient-  let verb = "describe"-  ggi <- getStoreItem shaBlurb stdBlurb verb c-  case ggi of-    Right ((iid, _), _) ->-      overlayToSlideshow "" $ itemDesc (storeFromC c) (itemToF iid 1)-    Left slides -> return slides---- * AllOwned---- | Display the sum of equipments and inventory of the whole party.-allOwnedHuman :: MonadClientUI m => m Slideshow-allOwnedHuman = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  describeItemC $ CTrunk (bfid b) (blid b) (bpos b)---- * SelectActor---- TODO: make the message (and for selectNoneHuman, pickLeader, etc.)--- optional, since they have a clear representation in the UI elsewhere.-selectActorHuman :: MonadClientUI m => m Slideshow-selectActorHuman = do-  leader <- getLeaderUI-  body <- getsState $ getActorBody leader-  wasMemeber <- getsClient $ ES.member leader . sselected-  let upd = if wasMemeber-            then ES.delete leader  -- already selected, deselect instead-            else ES.insert leader-  modifyClient $ \cli -> cli {sselected = upd $ sselected cli}-  let subject = partActor body-  msgAdd $ makeSentence [subject, if wasMemeber-                                  then "deselected"-                                  else "selected"]-  return mempty---- * SelectNone--selectNoneHuman :: (MonadClientUI m, MonadClient m) => m ()-selectNoneHuman = do-  side <- getsClient sside-  lidV <- viewedLevel-  oursAssocs <- getsState $ actorRegularAssocs (== side) lidV-  let ours = ES.fromList $ map fst oursAssocs-  oldSel <- getsClient sselected-  let wasNone = ES.null $ ES.intersection ours oldSel-      upd = if wasNone-            then ES.union  -- already all deselected; select all instead-            else ES.difference-  modifyClient $ \cli -> cli {sselected = upd (sselected cli) ours}-  let subject = "all party members on the level"-  msgAdd $ makeSentence [subject, if wasNone-                                  then "selected"-                                  else "deselected"]---- * Clear---- | Clear current messages, show the next screen if any.-clearHuman :: Monad m => m ()-clearHuman = return ()---- * Repeat---- Note that walk followed by repeat should not be equivalent to run,--- because the player can really use a command that does not stop--- at terrain change or when walking over items.-repeatHuman :: MonadClient m => Int -> m ()-repeatHuman n = do-  (_, seqPrevious, k) <- getsClient slastRecord-  let macro = concat $ replicate n $ reverse seqPrevious-  modifyClient $ \cli -> cli {slastPlay = macro ++ slastPlay cli}-  let slastRecord = ([], [], if k == 0 then 0 else maxK)-  modifyClient $ \cli -> cli {slastRecord}--maxK :: Int-maxK = 100---- * Record--recordHuman :: MonadClientUI m => m Slideshow-recordHuman = do-  (_seqCurrent, seqPrevious, k) <- getsClient slastRecord-  case k of-    0 -> do-      let slastRecord = ([], [], maxK)-      modifyClient $ \cli -> cli {slastRecord}-      promptToSlideshow $ "Macro will be recorded for up to"-                          <+> tshow maxK <+> "steps."-    _ -> do-      let slastRecord = (seqPrevious, [], 0)-      modifyClient $ \cli -> cli {slastRecord}-      promptToSlideshow $ "Macro recording interrupted after"-                          <+> tshow (maxK - k - 1) <+> "steps."---- * History--historyHuman :: MonadClientUI m => m Slideshow-historyHuman = do-  history <- getsClient shistory-  arena <- getArenaUI-  local <- getsState $ getLocalTime arena-  global <- getsState stime-  let msg = makeSentence-        [ "You survived for"-        , MU.CarWs (global `timeFitUp` timeTurn) "half-second turn"-        , "(this level:"-        , MU.Text (tshow (local `timeFitUp` timeTurn)) MU.:> ")" ]-        <+> "Past messages:"-  overlayToBlankSlideshow msg $ renderHistory history---- * MarkVision, MarkSmell, MarkSuspect--markVisionHuman :: MonadClientUI m => m ()-markVisionHuman = do-  modifyClient toggleMarkVision-  cur <- getsClient smarkVision-  msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."--markSmellHuman :: MonadClientUI m => m ()-markSmellHuman = do-  modifyClient toggleMarkSmell-  cur <- getsClient smarkSmell-  msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."--markSuspectHuman :: MonadClientUI m => m ()-markSuspectHuman = do-  modifyClient toggleMarkSuspect-  cur <- getsClient smarkSuspect-  msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."---- * Help---- | Display command help.-helpHuman :: MonadClientUI m => m Slideshow-helpHuman = do-  keyb <- askBinding-  return $! keyHelp keyb---- * MainMenu---- TODO: merge with the help screens better--- | Display the main menu.-mainMenuHuman :: MonadClientUI m => m Slideshow-mainMenuHuman = do-  Kind.COps{corule} <- getsState scops-  Binding{brevMap, bcmdList} <- askBinding-  scurDifficulty <- getsClient scurDifficulty-  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-  let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t-      pasteVersion art =-        let pathsVersion = rpathsVersion $ Kind.stdRuleset corule-            version = " Version " ++ showVersion pathsVersion-                      ++ " (frontend: " ++ frontendName-                      ++ ", engine: LambdaHack " ++ showVersion Self.version-                      ++ ") "-            versionLen = length version-        in init art ++ [take (80 - versionLen) (last art) ++ version]-      kds =  -- key-description pairs-        let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd)-            revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd brevMap-            cmds = [ (K.showKM km, desc)-                   | (km, (desc, [HumanCmd.CmdMenu], cmd)) <- bcmdList,-                     cmd /= HumanCmd.GameDifficultyCycle ]-        in [-             (fst (revLookup HumanCmd.Cancel), "back to playing")-           , (fst (revLookup HumanCmd.Accept), "see more help")-           ]-           ++ cmds-           ++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle)-                     , "next game difficulty"-                       <+> tshow sdifficultyCli-                       <+> "(current"-                       <+> tshow scurDifficulty <> ")" ) ]-      bindingLen = 25-      bindings =  -- key bindings to display-        let fmt (k, d) = T.justifyLeft bindingLen ' '-                         $ T.justifyLeft 7 ' ' k <> " " <> d-        in map fmt kds-      overwrite =  -- overwrite the art with key bindings-        let over [] line = ([], T.pack line)-            over bs@(binding : bsRest) line =-              let (prefix, lineRest) = break (=='{') line-                  (braces, suffix)   = span  (=='{') lineRest-              in if length braces == 25-                 then (bsRest, T.pack prefix <> binding-                               <> T.drop (T.length binding - bindingLen)-                                         (T.pack suffix))-                 else (bs, T.pack line)-        in snd . mapAccumL over bindings-      mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule-      menuOverlay =  -- TODO: switch to Text and use T.justifyLeft-        overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt-  case menuOverlay of-    [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt-    hd : tl -> overlayToBlankSlideshow hd (toOverlay tl)-               -- TODO: keys don't work if tl/=[]---- * Macro--macroHuman :: MonadClient m => [String] -> m ()-macroHuman kms =-  modifyClient $ \cli -> cli {slastPlay = map K.mkKM kms ++ slastPlay cli}---- * MoveCursor---- | Move the cursor. Assumes targeting mode.-moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow-moveCursorHuman dir n = do-  leader <- getLeaderUI-  stgtMode <- getsClient stgtMode-  let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode-  Level{lxsize, lysize} <- getLevel lidV-  lpos <- getsState $ bpos . getActorBody leader-  scursor <- getsClient scursor-  cursorPos <- cursorToPos-  let cpos = fromMaybe lpos cursorPos-      shiftB pos = shiftBounded lxsize lysize pos dir-      newPos = iterate shiftB cpos !! n-  if newPos == cpos then failMsg "never mind"-  else do-    let tgt = case scursor of-          TVector{} -> TVector $ newPos `vectorToFrom` lpos-          _ -> TPoint lidV newPos-    modifyClient $ \cli -> cli {scursor = tgt}-    doLook---- | Perform look around in the current position of the cursor.--- Normally expects targeting mode and so that a leader is picked.-doLook :: MonadClientUI m => m Slideshow-doLook = do-  Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops-  let unknownId = ouniqGroup "unknown space"-  stgtMode <- getsClient stgtMode-  case stgtMode of-    Nothing -> return mempty-    Just tgtMode -> do-      leader <- getLeaderUI-      let lidV = tgtLevelId tgtMode-      lvl <- getLevel lidV-      cursorPos <- cursorToPos-      per <- getPerFid lidV-      b <- getsState $ getActorBody leader-      let p = fromMaybe (bpos b) cursorPos-          canSee = ES.member p (totalVisible per)-      inhabitants <- if canSee-                     then getsState $ posToActors p lidV-                     else return []-      seps <- getsClient seps-      mnewEps <- makeLine b p seps-      itemToF <- itemToFullClient-      let aims = isJust mnewEps-          enemyMsg = case inhabitants of-            [] -> ""-            ((_, body), _) : rest ->-                 -- Even if it's the leader, give his proper name, not 'you'.-                 let subjects = map (partActor . snd . fst) inhabitants-                     subject = MU.WWandW subjects-                     verb = "be here"-                     desc = if not (null rest)  -- many actors-                            then ""-                            else case itemDisco $ itemToF (btrunk body) 1 of-                              Nothing -> ""-                              Just ItemDisco{itemKind} -> idesc itemKind-                     pdesc = if desc == "" then "" else "(" <> desc <> ")"-                 in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc-          vis | lvl `at` p == unknownId = "that is"-              | not canSee = "you remember"-              | not aims = "you are aware of"-              | otherwise = "you see"-      -- Show general info about current position.-      lookMsg <- lookAt True vis canSee p leader enemyMsg-      -- Check if there's something lying around at current position.-      let is = lvl `atI` p-      if EM.size is <= 2 then-        promptToSlideshow lookMsg-      else do-        msgAdd lookMsg  -- TODO: do not add to history-        floorItemOverlay lidV p---- | Create a list of item names.-floorItemOverlay :: MonadClientUI m => LevelId -> Point -> m Slideshow-floorItemOverlay lid p = describeItemC (CFloor lid p)---- * TgtFloor---- | Cycle targeting mode. Do not change position of the cursor,--- switch among things at that position.-tgtFloorHuman :: MonadClientUI m => m Slideshow-tgtFloorHuman = do-  lidV <- viewedLevel-  leader <- getLeaderUI-  lpos <- getsState $ bpos . getActorBody leader-  cursorPos <- cursorToPos-  scursor <- getsClient scursor-  stgtMode <- getsClient stgtMode-  bsAll <- getsState $ actorAssocs (const True) lidV-  let cursor = fromMaybe lpos cursorPos-      tgt = case scursor of-        _ | isNothing stgtMode ->  -- first key press: keep target-          scursor-        TEnemy a True -> TEnemy a False-        TEnemy{} -> TPoint lidV cursor-        TEnemyPos{} -> TPoint lidV cursor-        TPoint{} -> TVector $ cursor `vectorToFrom` lpos-        TVector{} ->-          -- For projectiles, we pick here the first that would be picked-          -- by '*', so that all other projectiles on the tile come next,-          -- without any intervening actors from other tiles.-          case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of-            Just (im, _) -> TEnemy im True-            Nothing -> TPoint lidV cursor-  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}-  doLook---- * TgtEnemy--tgtEnemyHuman :: MonadClientUI m => m Slideshow-tgtEnemyHuman = do-  lidV <- viewedLevel-  leader <- getLeaderUI-  lpos <- getsState $ bpos . getActorBody leader-  cursorPos <- cursorToPos-  scursor <- getsClient scursor-  stgtMode <- getsClient stgtMode-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  bsAll <- getsState $ actorAssocs (const True) lidV-  let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b)-      dbs = sortBy (comparing ordPos) bsAll-      pickUnderCursor =  -- switch to the enemy under cursor, if any-        let i = fromMaybe (-1)-                $ findIndex ((== cursorPos) . Just . bpos . snd) dbs-        in splitAt i dbs-      (permitAnyActor, (lt, gt)) = case scursor of-            TEnemy a permit | isJust stgtMode ->  -- pick next enemy-              let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs-              in (permit, splitAt (i + 1) dbs)-            TEnemy a permit ->  -- first key press, retarget old enemy-              let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs-              in (permit, splitAt i dbs)-            TEnemyPos _ _ _ permit -> (permit, pickUnderCursor)-            _ -> (False, pickUnderCursor)  -- the sensible default is only-foes-      gtlt = gt ++ lt-      isEnemy b = isAtWar fact (bfid b)-                  && not (bproj b)-      lf = filter (isEnemy . snd) gtlt-      tgt | permitAnyActor = case gtlt of-        (a, _) : _ -> TEnemy a True-        [] -> scursor  -- no actors in sight, stick to last target-          | otherwise = case lf of-        (a, _) : _ -> TEnemy a False-        [] -> scursor  -- no seen foes in sight, stick to last target-  -- Register the chosen enemy, to pick another on next invocation.-  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}-  doLook---- * TgtUnknown--tgtUnknownHuman :: MonadClientUI m => m Slideshow-tgtUnknownHuman = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  mpos <- closestUnknown leader-  case mpos of-    Nothing -> failMsg "no more unknown spots left"-    Just p -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      doLook---- * TgtItem--tgtItemHuman :: MonadClientUI m => m Slideshow-tgtItemHuman = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  items <- closestItems leader-  case items of-    [] -> failMsg "no more items remembered or visible"-    (_, (p, _)) : _ -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      doLook---- * TgtStair--tgtStairHuman :: MonadClientUI m => Bool -> m Slideshow-tgtStairHuman up = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  stairs <- closestTriggers (Just up) False leader-  case stairs of-    [] -> failMsg $ "no stairs"-                     <+> if up then "up" else "down"-    p : _ -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      doLook---- * TgtAscend---- | Change the displayed level in targeting mode to (at most)--- k levels shallower. Enters targeting mode, if not already in one.-tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow-tgtAscendHuman k = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  dungeon <- getsState sdungeon-  scursorOld <- getsClient scursor-  cursorPos <- cursorToPos-  lidV <- viewedLevel-  lvl <- getLevel lidV-  let rightStairs = case cursorPos of-        Nothing -> Nothing-        Just cpos ->-          let tile = lvl `at` cpos-          in if Tile.hasFeature cotile (F.Cause $ Effect.Ascend k) tile-             then Just cpos-             else Nothing-  case rightStairs of-    Just cpos -> do  -- stairs, in the right direction-      (nln, npos) <- getsState $ whereTo lidV cpos k . sdungeon-      assert (nln /= lidV `blame` "stairs looped" `twith` nln) skip-      nlvl <- getLevel nln-      -- Do not freely reveal the other end of the stairs.-      let ascDesc (F.Cause (Effect.Ascend _)) = True-          ascDesc _ = False-          scursor =-            if any ascDesc $ tfeature $ okind (nlvl `at` npos)-            then TPoint nln npos  -- already known as an exit, focus on it-            else scursorOld  -- unknown, do not reveal-      modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)}-      doLook-    Nothing ->  -- no stairs in the right direction-      case ascendInBranch dungeon k lidV of-        [] -> failMsg "no more levels in this direction"-        nln : _ -> do-          modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)}-          doLook---- * EpsIncr---- | Tweak the @eps@ parameter of the targeting digital line.-epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow-epsIncrHuman b = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then do-      modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1}-      return mempty-    else failMsg "never mind"  -- no visual feedback, so no sense---- * TgtClear--tgtClearHuman :: MonadClientUI m => m Slideshow-tgtClearHuman = do-  leader <- getLeaderUI-  tgt <- getsClient $ getTarget leader-  case tgt of-    Just _ -> do-      modifyClient $ updateTarget leader (const Nothing)-      return mempty-    Nothing -> do-      scursorOld <- getsClient scursor-      b <- getsState $ getActorBody leader-      let scursor = case scursorOld of-            TEnemy _ permit -> TEnemy leader permit-            TEnemyPos _ _ _ permit -> TEnemy leader permit-            TPoint{} -> TPoint (blid b) (bpos b)-            TVector{} -> TVector (Vector 0 0)-      modifyClient $ \cli -> cli {scursor}-      doLook---- * Cancel---- | Cancel something, e.g., targeting mode, resetting the cursor--- to the position of the leader. Chosen target is not invalidated.-cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow-cancelHuman h = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then targetReject-    else h  -- nothing to cancel right now, treat this as a command invocation---- | End targeting mode, rejecting the current position.-targetReject :: MonadClientUI m => m Slideshow-targetReject = do-  modifyClient $ \cli -> cli {stgtMode = Nothing}-  failMsg "targeting canceled"---- * Accept---- | Accept something, e.g., targeting mode, keeping cursor where it was.--- Or perform the default action, if nothing needs accepting.-acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow-acceptHuman h = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then do-      targetAccept-      return mempty-    else h  -- nothing to accept right now, treat this as a command invocation---- | End targeting mode, accepting the current position.-targetAccept :: MonadClientUI m => m ()-targetAccept = do-  endTargeting-  endTargetingMsg-  modifyClient $ \cli -> cli {stgtMode = Nothing}---- | End targeting mode, accepting the current position.-endTargeting :: MonadClientUI m => m ()-endTargeting = do-  leader <- getLeaderUI-  scursor <- getsClient scursor-  modifyClient $ updateTarget leader $ const $ Just scursor--endTargetingMsg :: MonadClientUI m => m ()-endTargetingMsg = do-  leader <- getLeaderUI-  (targetMsg, _) <- targetDescLeader leader-  subject <- partAidLeader leader-  msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]
− Game/LambdaHack/Client/UI/HumanCmd.hs 
@@ -1,166 +0,0 @@--- | Abstract syntax human player commands.-module Game.LambdaHack.Client.UI.HumanCmd-  ( CmdCategory(..), HumanCmd(..), Trigger(..)-  , noRemoteHumanCmd, categoryDescription, cmdDescription-  ) where--import Control.Exception.Assert.Sugar-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Vector--data CmdCategory =-    CmdMenu | CmdMove | CmdItem | CmdTgt | CmdAuto | CmdMeta-  | CmdDebug | CmdMinimal-  deriving (Show, Read, Eq)--categoryDescription :: CmdCategory -> Text-categoryDescription CmdMenu = "Main Menu"-categoryDescription CmdMove = "Terrain exploration and alteration"-categoryDescription CmdItem = "Item use"-categoryDescription CmdTgt = "Targeting"-categoryDescription CmdAuto = "Automation"-categoryDescription CmdMeta = "Assorted"-categoryDescription CmdDebug = "Debug"-categoryDescription CmdMinimal = "Minimal cheat sheet for casual play"---- | Abstract syntax of player commands.-data HumanCmd =-    -- Global.-    -- These usually take time.-    Move !Vector-  | Run !Vector-  | Wait-  | MoveItem ![CStore] !CStore !Text !Text !Bool-  | Project     ![Trigger]-  | Apply       ![Trigger]-  | AlterDir    ![Trigger]-  | TriggerTile ![Trigger]-  | StepToTarget-    -- Below this line, commands do not take time.-  | GameRestart !Text-  | GameExit-  | GameSave-  | Automate-    -- Local.-    -- Below this line, commands do not notify the server.-  | GameDifficultyCycle-  | PickLeader !Int-  | MemberCycle-  | MemberBack-  | DescribeItem !CStore-  | AllOwned-  | SelectActor-  | SelectNone-  | Clear-  | Repeat !Int-  | Record-  | History-  | MarkVision-  | MarkSmell-  | MarkSuspect-  | Help-  | MainMenu-  | Macro !Text ![String]-    -- These are mostly related to targeting.-  | MoveCursor !Vector !Int-  | TgtFloor-  | TgtEnemy-  | TgtUnknown-  | TgtItem-  | TgtStair !Bool-  | TgtAscend !Int-  | EpsIncr !Bool-  | TgtClear-  | Cancel-  | Accept-  deriving (Show, Read, Eq, Ord)--data Trigger =-    ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char}-  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}-  | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}-  deriving (Show, Read, Eq, Ord)---- | Commands that are forbidden on a remote level, because they--- would usually take time when invoked on one.--- Note that some commands that take time are not included,--- because they don't take time in targeting mode.-noRemoteHumanCmd :: HumanCmd -> Bool-noRemoteHumanCmd cmd = case cmd of-  Wait          -> True-  MoveItem{}    -> True-  Apply{}       -> True-  AlterDir{}    -> True-  StepToTarget  -> True-  _             -> False---- | Description of player commands.-cmdDescription :: HumanCmd -> Text-cmdDescription cmd = case cmd of-  Move v      -> "move" <+> compassText v-  Run v       -> "run" <+> compassText v-  Wait        -> "wait"-  MoveItem _ _ verb object _ -> verb <+> object-  Project ts  -> triggerDescription ts-  Apply ts    -> triggerDescription ts-  AlterDir ts -> triggerDescription ts-  TriggerTile ts -> triggerDescription ts-  StepToTarget -> "make one step towards the target"--  GameRestart t -> makePhrase ["new", MU.Capitalize $ MU.Text t, "game"]-  GameExit    -> "save and exit"-  GameSave    -> "save game"-  Automate    -> "automate faction (ESC to retake control)"--  GameDifficultyCycle -> "cycle difficulty of the next game"-  PickLeader{} -> "pick leader"-  MemberCycle -> "cycle among party members on the level"-  MemberBack  -> "cycle among all party members"-  DescribeItem CGround -> "describe items on the ground"-  DescribeItem COrgan -> "describe organs"-  DescribeItem CEqp -> "describe equipment of the leader"-  DescribeItem CInv -> "describe backpack inventory of the leader"-  DescribeItem CSha -> "describe the shared party stash"-  AllOwned    -> "describe all owned items"-  SelectActor -> "select (or deselect) a party member"-  SelectNone  -> "deselect (or select) all on the level"-  Clear       -> "clear messages"-  Repeat 1    -> "voice again the recorded commands"-  Repeat n    -> "voice the recorded commands" <+> tshow n <+> "times"-  Record      -> "start recording commands"-  History     -> "display player diary"-  MarkVision  -> "mark visible zone"-  MarkSmell   -> "mark smell clues"-  MarkSuspect -> "mark suspect terrain"-  Help        -> "display help"-  MainMenu    -> "display the Main Menu"-  Macro t _   -> t--  MoveCursor v 1 -> "move cursor" <+> compassText v-  MoveCursor v k ->-    "move cursor up to" <+> tshow k <+> "steps" <+> compassText v-  TgtFloor    -> "cycle targeting mode"-  TgtEnemy    -> "target enemy"-  TgtUnknown  -> "target the closest unknown spot"-  TgtItem     -> "target the closest item"-  TgtStair up -> "target the closest stairs" <+> if up then "up" else "down"-  TgtAscend k | k == 1  -> "target next shallower level"-  TgtAscend k | k >= 2  -> "target" <+> tshow k    <+> "levels shallower"-  TgtAscend k | k == -1 -> "target next deeper level"-  TgtAscend k | k <= -2 -> "target" <+> tshow (-k) <+> "levels deeper"-  TgtAscend _ -> assert `failure` "void level change when targeting"-                        `twith` cmd-  EpsIncr True  -> "swerve targeting line"-  EpsIncr False -> "unswerve targeting line"-  TgtClear    -> "clear target/cursor"-  Cancel      -> "cancel action, open Main Menu"-  Accept      -> "accept choice"--triggerDescription :: [Trigger] -> Text-triggerDescription [] = "trigger a thing"-triggerDescription (t : _) = makePhrase [verb t, object t]
− Game/LambdaHack/Client/UI/InventoryClient.hs 
@@ -1,402 +0,0 @@--- | Inventory management and party cycling.--- TODO: document-module Game.LambdaHack.Client.UI.InventoryClient-  ( failMsg, msgCannotChangeLeader-  , getGroupItem, getAnyItem, getStoreItem-  , memberCycle, memberBack, pickLeader-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.Char as Char-import qualified Data.EnumMap.Strict as EM-import Data.Function-import qualified Data.IntMap.Strict as IM-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.ItemSlot-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State--failMsg :: MonadClientUI m => Msg -> m Slideshow-failMsg msg = do-  stopPlayBack-  assert (not $ T.null msg) $ promptToSlideshow msg---- | Let a human player choose any item from a given group.--- Note that this does not guarantee the chosen item belongs to the group,--- as the player can override the choice.-getGroupItem :: MonadClientUI m-             => (Item -> Bool)  -- ^ which items to consider suitable-             -> MU.Part   -- ^ name of the item group-             -> MU.Part   -- ^ the verb describing the action-             -> [CStore]  -- ^ initial legal containers-             -> [CStore]  -- ^ legal containers after Calm taken into account-             -> m (SlideOrCmd ((ItemId, ItemFull), Container))-getGroupItem p itemsName verb cLegalRaw cLegalAfterCalm = do-  leader <- getLeaderUI-  getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s-  let cNotEmpty = not . EM.null . getCStoreBag-      cLegal = filter cNotEmpty cLegalAfterCalm  -- don't display empty stores-      tsuitable = const $ makePhrase [MU.Capitalize (MU.Ws itemsName)]-  getItem p (\b _ -> tsuitable b) tsuitable verb-          (map (CActor leader) cLegalRaw)-          (map (CActor leader) cLegal)-          True INone---- | Let the human player choose any item from a list of items--- and let him specify the number of items.-getAnyItem :: MonadClientUI m-           => MU.Part   -- ^ the verb describing the action-           -> [CStore]  -- ^ initial legal containers-           -> [CStore]  -- ^ legal containers after Calm taken into account-           -> Bool      -- ^ whether to ask, when the only item-                        --   in the starting container is suitable-           -> Bool      -- ^ whether to ask for the number of items-           -> m (SlideOrCmd ((ItemId, ItemFull), Container))-getAnyItem verb cLegalRaw cLegalAfterCalm askWhenLone askNumber = do-  leader <- getLeaderUI-  soc <- getItem (const True) (\_ _ -> "Items") (const "Items") verb-                 (map (CActor leader) cLegalRaw)-                 (map (CActor leader) cLegalAfterCalm)-                 askWhenLone INone-  case soc of-    Left _ -> return soc-    Right ((iid, itemFull), c) -> do-      socK <- pickNumber askNumber $ itemK itemFull-      case socK of-        Left slides -> return $ Left slides-        Right k ->-          return $ Right ((iid, itemFull{itemK=k}), c)---- | Display all items from a store and let the human player choose any--- or switch to any other store.-getStoreItem :: MonadClientUI m-             => (Actor -> [ItemFull] -> Text)-                                 -- ^ how to describe suitable items in CSha-             -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere-             -> MU.Part          -- ^ the verb describing the action-             -> Container        -- ^ initial container-             -> m (SlideOrCmd ((ItemId, ItemFull), Container))-getStoreItem shaBlurb stdBlurb verb cInitial = do-  leader <- getLeaderUI-  let allStores = map (CActor leader) [CEqp, CInv, CSha, CGround]-      cLegalRaw = cInitial : delete cInitial allStores-  getItem (const True) shaBlurb stdBlurb verb cLegalRaw cLegalRaw-          True ISuitable--data ItemDialogState = INone | ISuitable | IAll-  deriving (Show, Eq)---- | Let the human player choose a single, preferably suitable,--- item from a list of items.-getItem :: MonadClientUI m-        => (Item -> Bool)   -- ^ which items to consider suitable-        -> (Actor -> [ItemFull] -> Text)-                            -- ^ how to describe suitable items in CSha-        -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere-        -> MU.Part          -- ^ the verb describing the action-        -> [Container]      -- ^ initial legal containers-        -> [Container]      -- ^ legal containers with Calm taken into account-        -> Bool             -- ^ whether to ask, when the only item-                            --   in the starting container is suitable-        -> ItemDialogState  -- ^ the dialog state to start in-        -> m (SlideOrCmd ((ItemId, ItemFull), Container))-getItem p tshaSuit tsuitable verb cLegalRaw cLegal askWhenLone initalState = do-  leader <- getLeaderUI-  accessCBag <- getsState $ flip getCBag-  let storeAssocs = EM.assocs . accessCBag-      allAssocs = concatMap storeAssocs cLegal-      rawAssocs = concatMap storeAssocs cLegalRaw-  case (cLegal, allAssocs) of-    ([cStart], [(iid, k)]) | not askWhenLone -> do-      itemToF <- itemToFullClient-      return $ Right ((iid, itemToF iid k), cStart)-    (_ : _, _ : _) -> do-      let groundCs = filter ((== CGround) . storeFromC) cLegal-      mapM_ (updateItemSlot (Just leader)) $-        concatMap (EM.keys . accessCBag) groundCs-      transition p tshaSuit tsuitable verb cLegal initalState-    _ -> if null rawAssocs then do-           let tLegal = map (MU.Text . ppContainer) cLegalRaw-               ppLegal = makePhrase [MU.WWxW "nor" tLegal]-           failWith $ "no items" <+> ppLegal-         else failSer ItemNotCalm---- TODO: m is no longer needed and perhaps this can be simplified even more-data DefItemKey m = DefItemKey-  { defLabel  :: Text-  , defCond   :: Bool-  , defAction :: K.Key -> m (SlideOrCmd ((ItemId, ItemFull), Container))-  }--transition :: forall m. MonadClientUI m-           => (Item -> Bool)   -- ^ which items to consider suitable-           -> (Actor -> [ItemFull] -> Text)-                               -- ^ how to describe suitable items in CSha-           -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere-           -> MU.Part          -- ^ the verb describing the action-           -> [Container]-           -> ItemDialogState-           -> m (SlideOrCmd ((ItemId, ItemFull), Container))-transition _ _ _ verb [] iDS = assert `failure` (verb, iDS)-transition psuit tshaSuit tsuitable verb-           cLegal@(cCur:cRest) itemDialogState = do-  cops <- getsState scops-  (letterSlots, numberSlots) <- getsClient sslots-  leader <- getLeaderUI-  body <- getsState $ getActorBody leader-  activeItems <- activeItemsClient leader-  fact <- getsState $ (EM.! bfid body) . sfactionD-  hs <- partyAfterLeader leader-  bag <- getsState $ getCBag cCur-  itemToF <- itemToFullClient-  let getResult :: ItemId -> ((ItemId, ItemFull), Container)-      getResult iid = ((iid, itemToF iid (bag EM.! iid)), cCur)-      filterP s iid _ = psuit (getItemBody iid s)-  bagSuit <- getsState $ \s -> EM.filterWithKey (filterP s) bag-  let bagLetterSlots = EM.filter (`EM.member` bag) letterSlots-      bagNumberSlots = IM.filter (`EM.member` bag) numberSlots-      suitableLetterSlots = EM.filter (`EM.member` bagSuit) letterSlots-      keyDefs :: [(K.Key, DefItemKey m)]-      keyDefs = filter (defCond . snd)-        [ (K.Char '?', DefItemKey-           { defLabel = "?"-           , defCond = True-           , defAction = \_ -> case itemDialogState of-               INone ->-                 if EM.null bagSuit-                 then transition psuit tshaSuit tsuitable verb cLegal IAll-                 else transition psuit tshaSuit tsuitable verb cLegal ISuitable-               ISuitable | bag /= bagSuit ->-                 transition psuit tshaSuit tsuitable verb cLegal IAll-               _ -> transition psuit tshaSuit tsuitable verb cLegal INone-           })-        , (K.Char '/', DefItemKey-           { defLabel = "/"-           , defCond = length cLegal > 1-           , defAction = \_ -> transition psuit tshaSuit tsuitable verb-                                          (cRest ++ [cCur]) itemDialogState-           })-        , (K.Return,-           let enterSlots = if itemDialogState == IAll-                            then bagLetterSlots-                            else suitableLetterSlots-           in DefItemKey-           { defLabel = case EM.maxViewWithKey enterSlots of-               Nothing -> assert `failure` "no suitable items"-                                 `twith` enterSlots-               Just ((l, _), _) -> "RET(" <> T.singleton (slotChar l) <> ")"-           , defCond = not $ EM.null enterSlots-           , defAction = \_ -> case EM.maxView enterSlots of-               Nothing -> assert `failure` "no suitable items"-                                 `twith` enterSlots-               Just (iid, _) -> return $ Right $ getResult iid-           })-        , (K.Char '0', DefItemKey  -- TODO: accept any number and pick the item-           { defLabel = "0"-           , defCond = not $ IM.null bagNumberSlots-           , defAction = \_ -> case IM.minView bagNumberSlots of-               Nothing -> assert `failure` "no numbered items"-                                 `twith` bagNumberSlots-               Just (iid, _) -> return $ Right $ getResult iid-           })-        , (K.Tab, DefItemKey-           { defLabel = "TAB"-           , defCond = not (isAllMoveFact cops fact-                            || null (filter (\(_, b) ->-                                               blid b == blid body) hs))-           , defAction = \_ -> do-               err <- memberCycle False-               assert (err == mempty `blame` err) skip-               newLeader <- getLeaderUI-               let newC c = case c of-                     CActor _ cstore -> CActor newLeader cstore-                     _ -> c-                   newLegal = map newC cLegal-               transition psuit tshaSuit tsuitable verb newLegal itemDialogState-           })-        , (K.BackTab, DefItemKey-           { defLabel = "SHIFT-TAB"-           , defCond = not (isAllMoveFact cops fact || null hs)-           , defAction = \_ -> do-               err <- memberBack False-               assert (err == mempty `blame` err) skip-               newLeader <- getLeaderUI-               let newC c = case c of-                     CActor _ cstore -> CActor newLeader cstore-                     _ -> c-                   newLegal = map newC cLegal-               transition psuit tshaSuit tsuitable verb newLegal itemDialogState-           })-        ]-      lettersDef :: DefItemKey m-      lettersDef = DefItemKey-        { defLabel = slotRange $ EM.keys labelLetterSlots-        , defCond = True-        , defAction = \key -> case key of-            K.Char l -> case EM.lookup (SlotChar l) bagLetterSlots of-              Nothing -> assert `failure` "unexpected slot"-                                `twith` (l, bagLetterSlots)-              Just iid -> return $ Right $ getResult iid-            _ -> assert `failure` "unexpected key:" `twith` K.showKey key-        }-      ppCur = ppContainer cCur-      tsuit = if storeFromC cCur == CSha-              then tshaSuit body activeItems-              else tsuitable body-      (labelLetterSlots, bagFiltered, prompt) =-        case itemDialogState of-          INone     -> (suitableLetterSlots,-                        EM.empty,-                        makePhrase ["What to", verb] <+> ppCur <> "?")-          ISuitable -> (suitableLetterSlots,-                        bagSuit,-                        tsuit <+> ppCur <> ":")-          IAll      -> (bagLetterSlots,-                        bag,-                        "Items" <+> ppCur <> ":")-  io <- itemOverlay (storeFromC cCur) bagFiltered-  runDefItemKey keyDefs lettersDef io labelLetterSlots prompt--runDefItemKey :: MonadClientUI m-              => [(K.Key, DefItemKey m)]-              -> DefItemKey m-              -> Overlay-              -> EM.EnumMap SlotChar ItemId-              -> Text-              -> m (SlideOrCmd ((ItemId, ItemFull), Container))-runDefItemKey keyDefs lettersDef io labelLetterSlots prompt = do-  let itemKeys =-        let slotKeys = map (K.Char . slotChar) (EM.keys labelLetterSlots)-            defKeys = map fst keyDefs-        in zipWith K.KM (repeat K.NoModifier) $ slotKeys ++ defKeys-      choice = let letterRange = defLabel lettersDef-                   letterLabel | T.null letterRange = []-                               | otherwise = [letterRange]-                   keyLabels = letterLabel ++ map (defLabel . snd) keyDefs-               in "[" <> T.intercalate ", " keyLabels-  akm <- displayChoiceUI (prompt <+> choice) io itemKeys-  case akm of-    Left slides -> failSlides slides-    Right K.KM{..} -> do-      assert (modifier == K.NoModifier) skip-      case lookup key keyDefs of-        Just keyDef -> defAction keyDef key-        Nothing -> defAction lettersDef key--pickNumber :: MonadClientUI m => Bool -> Int -> m (SlideOrCmd Int)-pickNumber askNumber kAll = do-  let kDefault = kAll-  if askNumber && kAll > 1 then do-    let tDefault = tshow kDefault-        kbound = min 9 kAll-        kprompt = "Choose number [1-" <> tshow kbound-                  <> ", RET(" <> tDefault <> ")"-        kkeys = zipWith K.KM (repeat K.NoModifier)-                $ map (K.Char . Char.intToDigit) [1..kbound]-                  ++ [K.Return]-    kkm <- displayChoiceUI kprompt emptyOverlay kkeys-    case kkm of-      Left slides -> failSlides slides-      Right K.KM{key} ->-        case key of-          K.Char l -> return $ Right $ Char.digitToInt l-          K.Return -> return $ Right kDefault-          _ -> assert `failure` "unexpected key:" `twith` kkm-  else return $ Right kAll---- | Switches current member to the next on the level, if any, wrapping.-memberCycle :: MonadClientUI m => Bool -> m Slideshow-memberCycle verbose = do-  cops <- getsState scops-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  body <- getsState $ getActorBody leader-  hs <- partyAfterLeader leader-  case filter (\(_, b) -> blid b == blid body) hs of-    _ | isAllMoveFact cops fact -> failMsg msgCannotChangeLeader-    [] -> failMsg "Cannot pick any other member on this level."-    (np, b) : _ -> do-      success <- pickLeader verbose np-      assert (success `blame` "same leader" `twith` (leader, np, b)) skip-      return mempty---- | Switches current member to the previous in the whole dungeon, wrapping.-memberBack :: MonadClientUI m => Bool -> m Slideshow-memberBack verbose = do-  cops <- getsState scops-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  hs <- partyAfterLeader leader-  case reverse hs of-    _ | isAllMoveFact cops fact -> failMsg msgCannotChangeLeader-    [] -> failMsg "No other member in the party."-    (np, b) : _ -> do-      success <- pickLeader verbose np-      assert (success `blame` "same leader" `twith` (leader, np, b)) skip-      return mempty--msgCannotChangeLeader :: Msg-msgCannotChangeLeader = "leader change is automatic for your team"--partyAfterLeader :: MonadStateRead m => ActorId -> m [(ActorId, Actor)]-partyAfterLeader leader = do-  faction <- getsState $ bfid . getActorBody leader-  allA <- getsState $ EM.assocs . sactorD-  s <- getState-  let hs9 = mapMaybe (tryFindHeroK s faction) [0..9]-      factionA = filter (\(_, body) ->-        not (bproj body) && bfid body == faction) allA-      hs = hs9 ++ deleteFirstsBy ((==) `on` fst) factionA hs9-      i = fromMaybe (-1) $ findIndex ((== leader) . fst) hs-      (lt, gt) = (take i hs, drop (i + 1) hs)-  return $! gt ++ lt---- | Select a faction leader. False, if nothing to do.-pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool-pickLeader verbose aid = do-  leader <- getLeaderUI-  stgtMode <- getsClient stgtMode-  if leader == aid-    then return False -- already picked-    else do-      pbody <- getsState $ getActorBody aid-      assert (not (bproj pbody) `blame` "projectile chosen as the leader"-                                `twith` (aid, pbody)) skip-      -- Even if it's already the leader, give his proper name, not 'you'.-      let subject = partActor pbody-      when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"]-      -- Update client state.-      s <- getState-      modifyClient $ updateLeader aid s-      -- Move the cursor, if active, to the new level.-      case stgtMode of-        Nothing -> return ()-        Just _ ->-          modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode $ blid pbody}-      -- Inform about items, etc.-      lookMsg <- lookAt False "" True (bpos pbody) aid ""-      when verbose $ msgAdd lookMsg-      return True
− Game/LambdaHack/Client/UI/KeyBindings.hs 
@@ -1,141 +0,0 @@--- | Binding of keys to commands.--- No operation in this module involves the 'State' or 'Action' type.-module Game.LambdaHack.Client.UI.KeyBindings-  ( Binding(..), stdBinding, keyHelp-  ) where--import Control.Arrow (second)-import qualified Data.Char as Char-import Data.List-import qualified Data.Map.Strict as M-import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple (swap)--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.HumanCmd-import Game.LambdaHack.Common.Msg---- | Bindings and other information about human player commands.-data Binding = Binding-  { bcmdMap  :: !(M.Map K.KM (Text, [CmdCategory], HumanCmd))-                                        -- ^ binding of keys to commands-  , bcmdList :: ![(K.KM, (Text, [CmdCategory], HumanCmd))]-                                        -- ^ the properly ordered list-                                        --   of commands for the help menu-  , brevMap  :: !(M.Map HumanCmd K.KM)  -- ^ and from commands to their keys-  }---- | Binding of keys to movement and other standard commands,--- as well as commands defined in the config file.-stdBinding :: KeyKind  -- ^ default key bindings from the content-           -> Config   -- ^ game config-           -> Binding  -- ^ concrete binding-stdBinding copsClient !Config{configCommands, configVi, configLaptop} =-  let heroSelect k = ( K.KM { key=K.Char (Char.intToDigit k)-                            , modifier=K.NoModifier }-                     , ([CmdMeta], PickLeader k) )-      cmdWithHelp = rhumanCommands copsClient ++ configCommands-      cmdAll =-        cmdWithHelp-        ++ [(K.mkKM "KP_Begin", ([CmdMove], Wait))]-        ++ K.moveBinding configVi configLaptop (\v -> ([CmdMove], Move v))-                                               (\v -> ([CmdMove], Run v))-        ++ fmap heroSelect [0..6]-      mkDescribed (cats, cmd) = (cmdDescription cmd, cats, cmd)-  in Binding-  { bcmdMap = M.fromList $ map (second mkDescribed) cmdAll-  , bcmdList = map (second mkDescribed) cmdWithHelp-  , brevMap = M.fromList $ map swap $ map (second snd) cmdAll-  }---- | Produce a set of help screens from the key bindings.-keyHelp :: Binding -> Slideshow-keyHelp Binding{bcmdList} =-  let-    minimalBlurb =-      [ "Move throughout a level with numerical keypad or, optionally, other keys."-      , "Run ahead (until anything disturbs you) with SHIFT (or CTRL) and a key."-      , ""-      , "               7 8 9          7 8 9          y k u"-      , "                \\|/            \\|/            \\|/"-      , "               4-5-6          u-i-o          h-.-l"-      , "                /|\\            /|\\            /|\\"-      , "               1 2 3          j k l          b j n"-      , ""-      , "Interact with the dungeon using the following basic commands."-      , ""-      ]-    minCatBlurb =-      [ ""-      , "Press SPACE to see detailed descriptions of all commands."-      ]-    movBlurb =-      [ "Move throughout a level with numerical keypad (left diagram)"-      , "or its compact laptop replacement (middle) or Vi text editor keys"-      , "(right, also known as \"Rogue-like keys\"; can be enabled in config.ui.ini)."-      , "Run ahead, until anything disturbs you, with SHIFT (or CTRL) and a key."-      , ""-      , "               7 8 9          7 8 9          y k u"-      , "                \\|/            \\|/            \\|/"-      , "               4-5-6          u-i-o          h-.-l"-      , "                /|\\            /|\\            /|\\"-      , "               1 2 3          j k l          b j n"-      , ""-      , "In targeting mode the very same keys move the targeting cursor."-      , "Press '5' or 'i' or '.' to wait, bracing for blows, which reduces"-      , "any damage taken and makes it impossible for foes to displace you."-      , "You displace enemies or friends by bumping into them with SHIFT (or CTRL)."-      , ""-      , "Search, loot, open and attack by bumping into walls, doors and enemies."-      , "The best item to attack with is automatically chosen from among"-      , "weapons in your personal equipment and your unwounded organs."-      , ""-      , "Press SPACE to see command descriptions."-      ]-    categoryBlurb =-      [ ""-      , "Press SPACE to see the next page of command descriptions."-      ]-    lastBlurb =-      [ ""-      , "For more playing instructions see file PLAYING.md."-      , "Press SPACE to clear the messages and see the map again."-      ]-    fmt k h = T.justifyRight 72 ' '-              $ T.justifyLeft 15 ' ' k-                <> T.justifyLeft 41 ' ' h-    fmts s = " " <> T.justifyLeft 71 ' ' s-    minimalText = map fmts minimalBlurb-    movText = map fmts movBlurb-    minCatText = map fmts minCatBlurb-    categoryText = map fmts categoryBlurb-    lastText = map fmts lastBlurb-    keyCaption = fmt "keys" "command"-    coImage :: K.KM -> [K.KM]-    coImage k = k : sort [ from-                         | (from, (_, _, Macro _ [to])) <- bcmdList-                         , K.mkKM to == k ]-    disp k = T.concat $ intersperse " and " $ map K.showKM $ coImage k-    keys cat = [ fmt (disp k) h-               | (k, (h, cats, _)) <- bcmdList, cat `elem` cats, h /= "" ]-  in toSlideshow True-    [ [categoryDescription CmdMinimal-       <> ". [press SPACE to see all commands]"] ++ [""]-      ++ minimalText-      ++ [keyCaption] ++ keys CmdMinimal ++ minCatText ++ [moreMsg]-    , ["Movement. [press SPACE to advance]"] ++ [""]-      ++ movText ++ [moreMsg]-    , [categoryDescription CmdMove <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdMove ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdItem ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdTgt <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdTgt ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdAuto <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdAuto ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdMeta <> "."] ++ [""]-      ++ [keyCaption] ++ keys CmdMeta ++ lastText-    ]
− Game/LambdaHack/Client/UI/MonadClientUI.hs 
@@ -1,378 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- | Client monad for interacting with a human through UI.-module Game.LambdaHack.Client.UI.MonadClientUI-  ( -- * Client UI monad-    MonadClientUI( getsSession  -- exposed only to be implemented, not used-                 , liftIO  -- exposed only to be implemented, not used-                 )-  , SessionUI(..)-    -- * Display and key input-  , ColorMode(..)-  , promptGetKey, getKeyOverlayCommand, getInitConfirms-  , displayFrame, displayDelay, displayFrames, displayActorStart, drawOverlay-    -- * Assorted primitives-  , stopPlayBack, stopRunning, askConfig, askBinding-  , syncFrames, tryTakeMVarSescMVar, scoreToSlideshow-  , getLeaderUI, getArenaUI, viewedLevel-  , targetDescLeader, targetDescCursor-  , leaderTgtToPos, leaderTgtAims, cursorToPos-  ) where--import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU-import System.Time--import Game.LambdaHack.Client.BfsClient-import Game.LambdaHack.Client.CommonClient-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient hiding (liftIO)-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.DrawClient-import Game.LambdaHack.Client.UI.Frontend as Frontend-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind---- | 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-  { schanF   :: !ChanFrontend       -- ^ connection with the frontend-  , sbinding :: !Binding            -- ^ binding of keys to commands-  , sescMVar :: !(Maybe (MVar ()))-  , sconfig  :: !Config-  }--class MonadClient m => MonadClientUI m where-  getsSession  :: (SessionUI -> a) -> m a-  liftIO       :: IO a -> m a---- | Read a keystroke received from the frontend.-readConnFrontend :: MonadClientUI m => m K.KM-readConnFrontend = do-  ChanFrontend{responseF} <- getsSession schanF-  liftIO $ atomically $ readTQueue responseF---- | Write a UI request to the frontend.-writeConnFrontend :: MonadClientUI m => FrontReq -> m ()-writeConnFrontend efr = do-  ChanFrontend{requestF} <- getsSession schanF-  liftIO $ atomically $ writeTQueue requestF efr--promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM-promptGetKey frontKM frontFr = do-  escPressed <- tryTakeMVarSescMVar  -- this also clears the ESC-pressed  marker-  lastPlayOld <- getsClient slastPlay-  km <- case lastPlayOld of-    km : kms | not escPressed && (null frontKM || km `elem` frontKM) -> do-      displayFrame True $ Just frontFr-      -- Sync frames so that ESC doesn't skip frames.-      syncFrames-      modifyClient $ \cli -> cli {slastPlay = kms}-      return km-    _ -> do-      unless (null lastPlayOld) stopPlayBack  -- we can't continue playback-      writeConnFrontend FrontKey{..}-      readConnFrontend-  (seqCurrent, seqPrevious, k) <- getsClient slastRecord-  let slastRecord = (km : seqCurrent, seqPrevious, k)-  modifyClient $ \cli -> cli {slastRecord}-  return km---- | Display an overlay and wait for a human player command.-getKeyOverlayCommand :: MonadClientUI m => Bool -> Overlay -> m K.KM-getKeyOverlayCommand onBlank overlay = do-  frame <- drawOverlay onBlank ColorFull overlay-  promptGetKey [] frame---- | Display a slideshow, awaiting confirmation for each slide except the last.-getInitConfirms :: MonadClientUI m-                => ColorMode -> [K.KM] -> Slideshow -> m Bool-getInitConfirms dm frontClear slides = do-  let (onBlank, ovs) = slideshow slides-  frontSlides <- drawOverlays onBlank dm ovs-  -- The first two cases are optimizations:-  case frontSlides of-    [] -> return True-    [x] -> do-      displayFrame False $ Just x-      return True-    _ -> do-      writeConnFrontend FrontSlides{..}-      km <- readConnFrontend-      -- Don't clear ESC marker here, because the wait for confirms may-      -- block a ping and the ping would not see the ESC.-      return $! km /= K.escKM--displayFrame :: MonadClientUI m => Bool -> Maybe SingleFrame -> m ()-displayFrame isRunning mf = do-  let frame = case mf of-        Nothing -> FrontDelay-        Just fr | isRunning -> FrontRunningFrame fr-        Just fr -> FrontNormalFrame fr-  writeConnFrontend frame--displayDelay :: MonadClientUI m =>  m ()-displayDelay = writeConnFrontend FrontDelay---- | Push frames or delays to the frame queue.-displayFrames :: MonadClientUI m => Frames -> m ()-displayFrames = mapM_ (displayFrame False)---- | Push frames or delays to the frame queue. Additionally set @sdisplayed@.--- because animations not always happen after @SfxActorStart@ on the leader's--- level (e.g., death can lead to leader change to another level mid-turn,--- and there could be melee and animations on that level at the same moment).-displayActorStart :: MonadClientUI m => Actor -> Frames -> m ()-displayActorStart b frs = do-  mapM_ (displayFrame False) frs-  let ageDisp displayed = EM.insert (blid b) (btime b) displayed-  modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}---- | Draw the current level with the overlay on top.-drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame-drawOverlay sfBlank@True _ sfTop = do-  let sfLevel = []-      sfBottom = []-  return $! SingleFrame {..}-drawOverlay sfBlank@False dm sfTop = do-  lid <- viewedLevel-  mleader <- getsClient _sleader-  tgtPos <- leaderTgtToPos-  cursorPos <- cursorToPos-  let anyPos = fromMaybe (Point 0 0) cursorPos-      pathFromLeader leader = fmap Just $ getCacheBfsAndPath leader anyPos-  bfsmpath <- maybe (return Nothing) pathFromLeader mleader-  tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader-  cursorDesc <- targetDescCursor-  draw sfBlank dm lid cursorPos tgtPos bfsmpath cursorDesc tgtDesc sfTop--drawOverlays :: MonadClientUI m-             => Bool -> ColorMode -> [Overlay] -> m [SingleFrame]-drawOverlays _ _ [] = return []-drawOverlays sfBlank dm (topFirst : rest) = do-  fistFrame <- drawOverlay sfBlank dm topFirst-  let f topNext = fistFrame {sfTop = topNext}-  return $! fistFrame : map f rest  -- keep @rest@ lazy for responsiveness--stopPlayBack :: MonadClientUI m => m ()-stopPlayBack = do-  modifyClient $ \cli -> cli-    { slastPlay = []-    , slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli-                    in (seqCurrent, seqPrevious, 0)-    , swaitTimes = - swaitTimes cli-    }-  stopRunning--stopRunning :: MonadClientUI m => m ()-stopRunning = do-  srunning <- getsClient srunning-  case srunning of-    Nothing -> return ()-    Just RunParams{runLeader} -> do-      -- Switch to the original leader, from before the run start, unless dead.-      cops <- getsState scops-      side <- getsClient sside-      fact <- getsState $ (EM.! side) . sfactionD-      arena <- getArenaUI-      s <- getState-      when (memActor runLeader arena s && not (isAllMoveFact cops fact)) $-        modifyClient $ updateLeader runLeader s-      modifyClient (\cli -> cli { srunning = Nothing })--askConfig :: MonadClientUI m => m Config-askConfig = getsSession sconfig---- | Get the key binding.-askBinding :: MonadClientUI m => m Binding-askBinding = getsSession sbinding---- | Sync frames display with the frontend.-syncFrames :: MonadClientUI m => m ()-syncFrames = do-  -- Hack.-  writeConnFrontend FrontSlides{frontClear=[], frontSlides=[]}-  km <- readConnFrontend-  assert (km == K.spaceKM) skip--tryTakeMVarSescMVar :: MonadClientUI m => m Bool-tryTakeMVarSescMVar = do-  mescMVar <- getsSession sescMVar-  case mescMVar of-    Nothing -> return False-    Just escMVar -> do-      mUnit <- liftIO $ tryTakeMVar escMVar-      return $ isJust mUnit--scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow-scoreToSlideshow total status = do-  cops <- getsState scops-  fid <- getsClient sside-  fact <- getsState $ (EM.! fid) . sfactionD-  -- TODO: Re-read the table in case it's changed by a concurrent game.-  -- TODO: we should do this, and make sure we do that after server-  -- saved the updated score table, and not register, but read from it.-  -- Otherwise the score is not accurate, e.g., the number of victims.-  table <- getsState shigh-  time <- getsState stime-  date <- liftIO getClockTime-  scurDifficulty <- getsClient scurDifficulty-  factionD <- getsState sfactionD-  fightsSpawners <- fightsAgainstSpawners fid-  let showScore (ntable, pos) = HighScore.highSlideshow ntable pos-      diff | not $ playerUI $ gplayer fact = difficultyDefault-           | otherwise = scurDifficulty-      theirVic (fi, fa) | isAtWar fact fi-                          && not (isHorrorFact cops fa) = Just $ gvictims fa-                        | otherwise = Nothing-      theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD-      ourVic (fi, fa) | isAllied fact fi || fi == fid = Just $ gvictims fa-                      | otherwise = Nothing-      ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD-      (worthMentioning, rScore) =-        HighScore.register table total time status date diff-                           (playerName $ gplayer fact)-                           ourVictims theirVictims fightsSpawners-  return $! if worthMentioning then showScore rScore else mempty--getLeaderUI :: MonadClientUI m => m ActorId-getLeaderUI = do-  cli <- getClient-  case _sleader cli of-    Nothing -> assert `failure` "leader expected but not found" `twith` cli-    Just leader -> return leader--getArenaUI :: MonadClientUI m => m LevelId-getArenaUI = do-  mleader <- getsClient _sleader-  case mleader of-    Just leader -> getsState $ blid . getActorBody leader-    Nothing -> do-      side <- getsClient sside-      fact <- getsState $ (EM.! side) . sfactionD-      case gquit fact of-        Just Status{stDepth} -> return $! toEnum stDepth-        Nothing -> do-          dungeon <- getsState sdungeon-          let (minD, maxD) =-                case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of-                  (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-                  _ -> assert `failure` "empty dungeon" `twith` dungeon-          return $! max minD $ min maxD $ toEnum $ playerEntry $ gplayer fact--viewedLevel :: MonadClientUI m => m LevelId-viewedLevel = do-  arena <- getArenaUI-  stgtMode <- getsClient stgtMode-  return $! maybe arena tgtLevelId stgtMode--targetDesc :: MonadClientUI m => Maybe Target -> m (Text, Maybe Text)-targetDesc target = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  case target of-    Just (TEnemy aid _) -> do-      side <- getsClient sside-      b <- getsState $ getActorBody aid-      maxHP <- sumOrganEqpClient Effect.EqpSlotAddMaxHP aid-      let percentage = 100 * bhp b `div` xM (max 5 maxHP)-          stars | percentage < 20  = "[_____]"-                | percentage < 40  = "[*____]"-                | percentage < 60  = "[**___]"-                | percentage < 80  = "[***__]"-                | percentage < 100 = "[****_]"-                | otherwise        = "[*****]"-          hpIndicator = if bfid b == side then Nothing else Just stars-      return (bname b, hpIndicator)-    Just (TEnemyPos _ lid p _) -> do-      let hotText = if lid == lidV-                    then "hot spot" <+> (T.pack . show) p-                    else "a hot spot on level" <+> tshow (abs $ fromEnum lid)-      return (hotText, Nothing)-    Just (TPoint lid p) -> do-      pointedText <--        if lid == lidV-        then do-          lvl <- getLevel lid-          case EM.assocs $ lvl `atI` p of-            [] -> return $! "exact spot" <+> (T.pack . show) p-            [(iid, k)] -> do-              itemToF <- itemToFullClient-              let (name, stats) = partItem CGround (itemToF iid k)-              return $! makePhrase $ if k == 1-                                     then [name, stats]  -- "a sword" too wordy-                                     else [MU.CarWs k name, stats]-            _ -> return $! "many items at" <+> (T.pack . show) p-        else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid)-      return (pointedText, Nothing)-    Just TVector{} ->-      case mleader of-        Nothing -> return ("a relative shift", Nothing)-        Just aid -> do-          tgtPos <- aidTgtToPos aid lidV target-          let invalidMsg = "an invalid relative shift"-              validMsg p = "shift to" <+> (T.pack . show) p-          return (maybe invalidMsg validMsg tgtPos, Nothing)-    Nothing -> return ("cursor location", Nothing)--targetDescLeader :: MonadClientUI m => ActorId -> m (Text, Maybe Text)-targetDescLeader leader = do-  tgt <- getsClient $ getTarget leader-  targetDesc tgt--targetDescCursor :: MonadClientUI m => m (Text, Maybe Text)-targetDescCursor = do-  scursor <- getsClient scursor-  targetDesc $ Just scursor--leaderTgtToPos :: MonadClientUI m => m (Maybe Point)-leaderTgtToPos = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  case mleader of-    Nothing -> return Nothing-    Just aid -> do-      tgt <- getsClient $ getTarget aid-      aidTgtToPos aid lidV tgt--leaderTgtAims :: MonadClientUI m => m (Either Text Int)-leaderTgtAims = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  case mleader of-    Nothing -> return $ Left "no leader to target with"-    Just aid -> do-      tgt <- getsClient $ getTarget aid-      aidTgtAims aid lidV tgt--cursorToPos :: MonadClientUI m => m (Maybe Point)-cursorToPos = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  scursor <- getsClient scursor-  case mleader of-    Nothing -> return Nothing-    Just aid -> aidTgtToPos aid lidV $ Just scursor
− Game/LambdaHack/Client/UI/MsgClient.hs 
@@ -1,138 +0,0 @@--- | Client monad for interacting with a human through UI.-module Game.LambdaHack.Client.UI.MsgClient-  ( msgAdd, msgReset, recordHistory-  , SlideOrCmd, failWith, failSlides, failSer-  , lookAt, itemOverlay-  ) where--import Control.Arrow (first)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.IntMap.Strict as IM-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified Game.LambdaHack.Common.Kind as Kind-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.CommonClient-import Game.LambdaHack.Client.ItemSlot-import Game.LambdaHack.Client.MonadClient hiding (liftIO)-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.WidgetClient-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.TileKind---- | 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 :: MonadClientUI m => Msg -> m ()-msgReset msg = modifyClient $ \d -> d {sreport = singletonReport msg}---- | Store current report in the history and reset report.-recordHistory :: MonadClientUI m => m ()-recordHistory = do-  StateClient{sreport, shistory} <- getClient-  unless (nullReport sreport) $ do-    Config{configHistoryMax} <- askConfig-    msgReset ""-    let nhistory = takeHistory configHistoryMax $! addReport sreport shistory-    modifyClient $ \cli -> cli {shistory = nhistory}--type SlideOrCmd a = Either Slideshow a--failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a)-failWith msg = do-  stopPlayBack-  assert (not $ T.null msg) $ fmap Left $ promptToSlideshow msg--failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a)-failSlides slides = do-  stopPlayBack-  return $ Left slides--failSer :: MonadClientUI m => ReqFailure -> m (SlideOrCmd a)-failSer = failWith . showReqFailure---- | Produces a textual description of the terrain and items at an already--- explored position. Mute for unknown positions.--- The detailed variant is for use in the targeting mode.-lookAt :: MonadClientUI m-       => Bool       -- ^ detailed?-       -> Text       -- ^ how to start tile description-       -> Bool       -- ^ can be seen right now?-       -> Point      -- ^ position to describe-       -> ActorId    -- ^ the actor that looks-       -> Text       -- ^ an extra sentence to print-       -> m Text-lookAt detailed tilePrefix canSee pos aid msg = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  itemToF <- itemToFullClient-  lidV <- viewedLevel-  lvl <- getLevel lidV-  b <- getsState $ getActorBody aid-  subject <- partAidLeader aid-  let is = lvl `atI` pos-      verb = MU.Text $ if pos == bpos b-                       then "stand on"-                       else if canSee then "notice" else "remember"-  let nWs (iid, k) = partItemWs k CGround (itemToF iid k)-      isd = case detailed of-              _ | EM.size is == 0 -> ""-              _ | EM.size is <= 2 ->-                makeSentence [ MU.SubjectVerbSg subject verb-                             , MU.WWandW $ map nWs $ EM.assocs is]-              True -> "\n"-              _ -> "Items here."-      tile = lvl `at` pos-      obscured | knownLsecret lvl-                 && tile /= hideTile cotile lvl pos = "partially obscured"-               | otherwise = ""-      tileText = obscured <+> tname (okind tile)-      tilePart | T.null tilePrefix = MU.Text tileText-               | otherwise = MU.AW $ MU.Text tileText-      tileDesc = [MU.Text tilePrefix, tilePart]-  if not (null (Tile.causeEffects cotile tile)) then-    return $! makeSentence ("activable:" : tileDesc)-              <+> msg <+> isd-  else if detailed then-    return $! makeSentence tileDesc-              <+> msg <+> isd-  else return $! msg <+> isd---- | Create a list of item names.-itemOverlay :: MonadClient m => CStore -> ItemBag -> m Overlay-itemOverlay cstore bag = do-  itemToF <- itemToFullClient-  (letterSlots, numberSlots) <- getsClient sslots-  let pr (l, iid) =-        case EM.lookup iid bag of-          Nothing -> Nothing-          Just k ->-            let itemFull = itemToF iid k-                -- TODO: add color item symbols as soon as we have a menu-                -- with all items visible on the floor or known to player-                -- symbol = jsymbol $ itemBase itemFull-            in Just $ makePhrase [ slotLabel l, "-"  -- MU.String [symbol]-                                 , partItemWs k cstore itemFull ]-                           <> " "-  return $! toOverlay $ mapMaybe pr-    $ map (first Left) (EM.assocs letterSlots)-      ++ (map (first Right) (IM.assocs numberSlots))
− Game/LambdaHack/Client/UI/RunClient.hs 
@@ -1,283 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- | Running and disturbance.------ The general rule is: whatever is behind you (and so ignored previously),--- determines what you ignore moving forward. This is calcaulated--- separately for the tiles to the left, to the right and in the middle--- along the running direction. So, if you want to ignore something--- start running when you stand on it (or to the right or left, respectively)--- or by entering it (or passing to the right or left, respectively).------ Some things are never ignored, such as: enemies seen, imporant messages--- heard, solid tiles and actors in the way.-module Game.LambdaHack.Client.UI.RunClient-  ( continueRun, moveRunAid-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.ByteString.Char8 as BS-import qualified Data.EnumMap.Strict as EM-import Data.Function-import Data.List-import Data.Maybe--import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind---- | Continue running in the given direction.-continueRun :: MonadClient m-            => RunParams -> m (Either Msg (RunParams, RequestAnyAbility))-continueRun paramOld =-  case paramOld of-    RunParams{ runMembers = []-             , runStopMsg = Just stopMsg } -> return $ Left stopMsg-    RunParams{ runLeader-             , runMembers = r : rs-             , runDist = 0-             , runStopMsg-             , runInitDir = Just dir } ->-      if r == runLeader then do-        -- Start a many-actor run with distance 1, to prevent changing-        -- direction on first turn, if the original direction is blocked.-        -- We want our runners to keep formation.-        let runDistNew = if null rs then 0 else 1-        continueRun paramOld{runDist = runDistNew, runInitDir = Nothing}-      else do-        runOutcome <- continueRunDir r 0 (Just dir)-        case runOutcome of-          Left "" -> do  -- hack; means that zeroth step OK-            runStopOrCmd <- moveRunAid r dir-            let runMembersNew = if isJust runStopMsg then rs else rs ++ [r]-                paramNew = paramOld {runMembers = runMembersNew}-            case runStopOrCmd of-              Left stopMsg -> assert `failure` (paramOld, stopMsg)-              Right runCmd -> do-                s <- getState-                modifyClient $ updateLeader r s-                return $ Right (paramNew, runCmd)-          Left runStopMsgCurrent -> do-            let runStopMsgNew = fromMaybe runStopMsgCurrent runStopMsg-                paramNew = paramOld { runMembers = rs-                                    , runStopMsg = Just runStopMsgNew }-            continueRun paramNew-          _ -> assert `failure` (paramOld, runOutcome)-    RunParams{ runLeader-             , runMembers = r : rs-             , runDist-             , runStopMsg-             , runInitDir = Nothing } -> do-      let runDistNew = if r == runLeader then runDist + 1 else runDist-      mdirOrRunStopMsgCurrent <- continueRunDir r runDistNew Nothing-      let runStopMsgCurrent =-            either Just (const Nothing) mdirOrRunStopMsgCurrent-          runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent-          -- We check @runStopMsgNew@, because even if the current actor-          -- runs OK, we want to stop soon if some others had to stop.-          runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]-          paramNew = paramOld { runMembers = runMembersNew-                              , runDist = runDistNew-                              , runStopMsg = runStopMsgNew }-      case mdirOrRunStopMsgCurrent of-        Left _ -> continueRun paramNew  -- run all undisturbed; only one time-        Right dir -> do-          s <- getState-          modifyClient $ updateLeader r s-          return $ Right (paramNew, RequestAnyAbility $ ReqMove dir)-      -- The potential invisible actor is hit. War is started without asking.-    _ -> assert `failure` paramOld---- | Actor moves or searches or alters. No visible actor at the position.-moveRunAid :: MonadClient m-           => ActorId -> Vector -> m (Either Msg RequestAnyAbility)-moveRunAid source dir = do-  cops@Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-  lvl <- getLevel lid-  let spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-      t = lvl `at` tpos-      runStopOrCmd =-        -- Movement requires full access.-        if accessible cops lvl spos tpos then-          -- The potential invisible actor is hit. War started without asking.-          Right $ RequestAnyAbility $ ReqMove dir-        -- No access, so search and/or alter the tile. Non-walkability is-        -- not implied by the lack of access.-        else if not (Tile.isWalkable cotile t)-                && (not (knownLsecret lvl)-                    || (isSecretPos lvl tpos  -- possible secrets here-                        && (Tile.isSuspect cotile t  -- not yet searched-                            || Tile.hideAs cotile t /= t))  -- search again-                    || Tile.isOpenable cotile t-                    || Tile.isClosable cotile t-                    || Tile.isChangeable cotile t) then-          if not $ EM.null $ lvl `atI` tpos then-            Left $ showReqFailure AlterBlockItem-          else-            Right $ RequestAnyAbility $ ReqAlter tpos Nothing-            -- We don't use MoveSer, because we don't hit invisible actors.-            -- The potential invisible actor, e.g., in a wall or in-            -- an inaccessible doorway, is made known, taking a turn.-            -- If server performed an attack for free-            -- on the invisible actor anyway, the player (or AI)-            -- would be tempted to repeatedly hit random walls-            -- in hopes of killing a monster lurking within.-            -- If the action had a cost, misclicks would incur the cost, too.-            -- Right now the player may repeatedly alter tiles trying to learn-            -- about invisible pass-wall actors, but it costs a turn-            -- and does not harm the invisible actors, so it's not tempting.-       -- Ignore a known boring, not accessible tile.-       else Left "never mind"-  return $! runStopOrCmd---- | This function implements the actual logic of running. It checks if we--- have to stop running because something interesting cropped up,--- it ajusts the direction given by the vector if we reached--- a corridor's corner (we never change direction except in corridors)--- and it increments the counter of traversed tiles.-continueRunDir :: MonadClient m-               => ActorId -> Int -> Maybe Vector -> m (Either Msg Vector)-continueRunDir aid distLast mdir = do-  sreport <- getsClient sreport -- TODO: check the message before it goes into history-  let boringMsgs = map BS.pack [ "You hear some noises."-                               , "reveals that the" ]-      boring repLine = any (`BS.isInfixOf` repLine) boringMsgs-      -- TODO: use a regexp from the UI config instead-      msgShown  = isJust $ findInReport (not . boring) sreport-  if msgShown then return $ Left "message shown"-  else do-    let maxDistance = 20-    cops@Kind.COps{cotile} <- getsState scops-    body <- getsState $ getActorBody aid-    let lid = blid body-    lvl <- getLevel lid-    let posHere = bpos body-        posLast = boldpos body-        dirLast = posHere `vectorToFrom` posLast-        dir = fromMaybe dirLast mdir-        posThere = posHere `shift` dir-    actorsThere <- getsState $ posToActors posThere lid-    let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))-        check-          | not $ null actorsThere = return $ Left "actor in the way"-                         -- don't displace actors, except with leader in step 1-          | distLast >= maxDistance =-              return $ Left $ "reached max run distance" <+> tshow maxDistance-          | accessibleDir cops lvl posHere dir =-              if distLast == 0-              then return $ Left ""  -- hack; means that zeroth step OK-              else checkAndRun aid dir-          | distLast /= 1 = return $ Left "blocked"-                            -- don't change direction, except in step 1-          | openableLast = return $ Left "blocked by a closed door"-                           -- the player may prefer to open the door-          | otherwise =-              -- Assume turning is permitted, because this is the start-              -- of the run, so the situation is mostly known to the player-              tryTurning aid-    check--tryTurning :: MonadClient m-           => ActorId -> m (Either Msg Vector)-tryTurning aid = do-  cops@Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  let lid = blid body-  lvl <- getLevel lid-  let posHere = bpos body-      posLast = boldpos body-      dirLast = posHere `vectorToFrom` posLast-  let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))-      dirEnterable dir = accessibleDir cops lvl posHere dir || openableDir dir-      dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2]-      dirSimilar dir = dirNearby dirLast dir && dirEnterable dir-      dirsSimilar = filter dirSimilar moves-  case dirsSimilar of-    [] -> return $ Left "dead end"-    d1 : ds | all (dirNearby d1) ds ->  -- only one or two directions possible-      case sortBy (compare `on` euclidDistSqVector dirLast)-           $ filter (accessibleDir cops lvl posHere) $ d1 : ds of-        [] ->-          return $ Left "blocked and all similar directions are closed doors"-        d : _ -> checkAndRun aid d-    _ -> return $ Left "blocked and many distant similar directions found"---- The direction is different than the original, if called from @tryTurning@--- and the same if from @continueRunDir@.-checkAndRun :: MonadClient m-            => ActorId -> Vector -> m (Either Msg Vector)-checkAndRun aid dir = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  body <- getsState $ getActorBody aid-  smarkSuspect <- getsClient smarkSuspect-  let lid = blid body-  lvl <- getLevel lid-  let posHere = bpos body-      posHasItems pos = not $ EM.null $ lvl `atI` pos-      posThere = posHere `shift` dir-  actorsThere <- getsState $ posToActors posThere lid-  let posLast = boldpos body-      dirLast = posHere `vectorToFrom` posLast-      -- This is supposed to work on unit vectors --- diagonal, as well as,-      -- vertical and horizontal.-      anglePos :: Point -> Vector -> RadianAngle -> Point-      anglePos pos d angle = shift pos (rotate angle d)-      -- We assume the tiles have not changes since last running step.-      -- If they did, we don't care --- running should be stopped-      -- because of the change of nearby tiles then (TODO).-      -- We don't take into account the two tiles at the rear of last-      -- surroundings, because the actor may have come from there-      -- (via a diagonal move) and if so, he may be interested in such tiles.-      -- If he arrived directly from the right or left, he is responsible-      -- for starting the run further away, if he does not want to ignore-      -- such tiles as the ones he came from.-      tileLast = lvl `at` posLast-      tileHere = lvl `at` posHere-      tileThere = lvl `at` posThere-      leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]-                   ++ map (anglePos posHere dir) [pi/2, 3*pi/4]-      rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]-                    ++ map (anglePos posHere dir) [-pi/2, -3*pi/4]-      leftForwardPosHere = anglePos posHere dir (pi/4)-      rightForwardPosHere = anglePos posHere dir (-pi/4)-      leftTilesLast = map (lvl `at`) leftPsLast-      rightTilesLast = map (lvl `at`) rightPsLast-      leftForwardTileHere = lvl `at` leftForwardPosHere-      rightForwardTileHere = lvl `at` rightForwardPosHere-      featAt = actionFeatures smarkSuspect . okind-      terrainChangeMiddle = null (Tile.causeEffects cotile tileThere)-                              -- step into; will stop next turn due to message-                            && featAt tileThere-                               `notElem` map featAt [tileLast, tileHere]-      terrainChangeLeft = featAt leftForwardTileHere-                          `notElem` map featAt leftTilesLast-      terrainChangeRight = featAt rightForwardTileHere-                           `notElem` map featAt rightTilesLast-      itemChangeLeft = posHasItems leftForwardPosHere-                       `notElem` map posHasItems leftPsLast-      itemChangeRight = posHasItems rightForwardPosHere-                        `notElem` map posHasItems rightPsLast-      check-        | not $ null actorsThere = return $ Left "actor in the way"-                       -- Actor in possibly another direction tnat original.-        | terrainChangeLeft = return $ Left "terrain change on the left"-        | terrainChangeRight = return $ Left "terrain change on the right"-        | itemChangeLeft = return $ Left "item change on the left"-        | itemChangeRight = return $ Left "item change on the right"-        | terrainChangeMiddle = return $ Left "terrain change in the middle"-        | otherwise = return $ Right dir-  check
− Game/LambdaHack/Client/UI/StartupFrontendClient.hs 
@@ -1,65 +0,0 @@--- | Startup up the frontend together with the server, which starts up clients.-module Game.LambdaHack.Client.UI.StartupFrontendClient-  ( srtFrontend-  ) where--import Control.Concurrent.Async-import qualified Control.Concurrent.STM as STM-import Control.Exception.Assert.Sugar--import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.Frontend-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.State---- | 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.-srtFrontend :: (DebugModeCli -> SessionUI -> State -> StateClient-                -> chanServerUI-                -> IO ())-            -> (DebugModeCli -> SessionUI -> State -> StateClient-                -> chanServerAI-                -> IO ())-            -> KeyKind -> Kind.COps -> DebugModeCli-            -> ((FactionId -> chanServerUI -> IO ())-               -> (FactionId -> chanServerAI -> IO ())-               -> IO ())-            -> IO ()-srtFrontend executorUI executorAI-            copsClient cops@Kind.COps{corule} sdebugCli exeServer = do-  -- UI config reloaded at each client start.-  sconfig <- mkConfig corule-  let !sbinding = stdBinding copsClient sconfig  -- evaluate to check for errors-      sdebugMode = applyConfigToDebug sconfig sdebugCli corule-  defaultHist <- defaultHistory-  let cli = defStateClient defaultHist emptyReport-      s = updateCOps (const cops) emptyState-      exeClientAI fid =-        let noSession = assert `failure` "AI client needs no UI session"-                               `twith` fid-        in executorAI sdebugMode noSession s (cli fid True)-      exeClientUI sescMVar loopFrontend fid chanServerUI = do-        responseF <- STM.newTQueueIO-        requestF <- STM.newTQueueIO-        let schanF = ChanFrontend{..}-        a <- async $ loopFrontend schanF-        link a-        executorUI sdebugMode SessionUI{..} s (cli fid False) chanServerUI-        STM.atomically $ STM.writeTQueue requestF FrontFinish-        wait a-  -- TODO: let each client start his own raw frontend (e.g., gtk, though-  -- that leads to disaster); then don't give server as the argument-  -- to startupF, but the Client.hs (when it ends, gtk ends); server is-  -- then forked separately and client doesn't need to know about-  -- starting servers.-  startupF sdebugMode $ \sescMVar loopFrontend ->-    exeServer (exeClientUI sescMVar loopFrontend) exeClientAI
− Game/LambdaHack/Client/UI/WidgetClient.hs 
@@ -1,156 +0,0 @@--- | A set of widgets for UI clients.-module Game.LambdaHack.Client.UI.WidgetClient-  ( displayMore, displayYesNo, displayChoiceUI, displayPush, displayPushIfLid-  , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow-  , animate, fadeOutOrIn-  ) where--import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Monoid--import Game.LambdaHack.Client.BfsClient-import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.MonadClient hiding (liftIO)-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.DrawClient-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind---- | 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.escKM-             ]-  K.KM {key} <- promptGetKey keys frame-  case key of-    K.Char 'y' -> return True-    _          -> return False---- | Display a message 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-  slides <- promptToSlideshow $ prompt <+> moreMsg-  -- Two frames drawn total (unless 'prompt' very long).-  getInitConfirms dm [] $ slides <> toSlideshow False [[]]---- | Print a yes/no question and return the player's answer. Use black--- and white colours to turn player's attention to the choice.-displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool-displayYesNo dm prompt = do-  sli <- promptToSlideshow $ prompt <+> yesnoMsg-  frame <- drawOverlay False dm $ head . snd $ slideshow sli-  getYesNo frame---- TODO: generalize getInitConfirms and displayChoiceUI to a single op--- | Print a prompt and an overlay and wait for a player keypress.--- If many overlays, scroll screenfuls with SPACE. Do not wrap screenfuls--- (in some menus @?@ cycles views, so the user can restart from the top).-displayChoiceUI :: MonadClientUI m-                => Msg -> Overlay -> [K.KM] -> m (Either Slideshow K.KM)-displayChoiceUI prompt ov keys = do-  (_, ovs) <- fmap slideshow $ overlayToSlideshow (prompt <> ", ESC]") ov-  let legalKeys = [K.spaceKM, K.escKM]-        ++ keys-      loop [] = fmap Left $ promptToSlideshow "never mind"-      loop (x : xs) = do-        frame <- drawOverlay False ColorFull x-        km@K.KM {..} <- promptGetKey legalKeys frame-        case key of-          K.Esc -> fmap Left $ promptToSlideshow "never mind"-          K.Space -> loop xs-          _ -> return $ Right km-  loop ovs---- TODO: if more slides, don't take head, but do as in getInitConfirms,--- but then we have to clear the messages or they get redisplayed--- each time screen is refreshed.--- | 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-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  sls <- promptToSlideshow ""-  let slide = head . snd $ slideshow sls-      underAI = playerAI $ gplayer fact-  frame <- drawOverlay False ColorFull slide-  -- Visually speed up (by remving all empty frames) the show of the sequence-  -- of the move frames if the player is running.-  srunning <- getsClient srunning-  lastPlay <- getsClient slastPlay-  displayFrame (isJust srunning || not (null lastPlay) || underAI)-               (Just frame)--displayPushIfLid :: MonadClientUI m => LevelId -> m ()-displayPushIfLid lid = do-  arena <- getArenaUI-  when (arena == lid) displayPush---- | 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 emptyOverlay---- | The prompt is shown after the current message at the top of each slide.--- Together they may take more than one line. The prompt is not added--- 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-  Level{lxsize, lysize} <- getLevel lid  -- TODO: screen length or viewLevel-  sreport <- getsClient sreport-  let msg = splitReport lxsize (addMsg sreport prompt)-  return $! splitOverlay False (lysize + 1) msg overlay--overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow-overlayToBlankSlideshow prompt overlay = do-  lid <- getArenaUI-  Level{lysize} <- getLevel lid  -- TODO: screen length or viewLevel-  return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay---- 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-  sreport <- getsClient sreport-  mleader <- getsClient _sleader-  Level{lxsize, lysize} <- getLevel arena-  tgtPos <- leaderTgtToPos-  cursorPos <- cursorToPos-  let anyPos = fromMaybe (Point 0 0) cursorPos-      pathFromLeader leader = fmap Just $ getCacheBfsAndPath leader anyPos-  bfsmpath <- maybe (return Nothing) pathFromLeader mleader-  tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader-  cursorDesc <- targetDescCursor-  let over = renderReport sreport-      topLineOnly = truncateToOverlay over-  basicFrame <--    draw False ColorFull arena cursorPos tgtPos-         bfsmpath cursorDesc tgtDesc topLineOnly-  snoAnim <- getsClient $ snoAnim . sdebugCli-  return $! if fromMaybe False snoAnim-            then [Just basicFrame]-            else renderAnim lxsize lysize basicFrame anim--fadeOutOrIn :: MonadClientUI m => Bool -> m ()-fadeOutOrIn out = do-  let topRight = True-  lid <- getArenaUI-  Level{lxsize, lysize} <- getLevel lid-  animMap <- rndToAction $ fadeout out topRight 2 lxsize lysize-  animFrs <- animate lid animMap-  displayFrames animFrs
− Game/LambdaHack/Common/Ability.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | AI strategy abilities.-module Game.LambdaHack.Common.Ability-  ( Ability(..), Skills, zeroSkills, unitSkills, addSkills, scaleSkills-  ) where--import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.Hashable (Hashable)-import GHC.Generics (Generic)---- | Actor and faction abilities corresponding to client-server requests.-data Ability =-    AbMove-  | AbMelee-  | AbDisplace-  | AbAlter-  | AbWait-  | AbMoveItem-  | AbProject-  | AbApply-  | AbTrigger-  deriving (Read, Eq, Ord, Generic, Enum, Bounded)---- skill level in particular abilities.-type Skills = EM.EnumMap Ability Int--zeroSkills :: Skills-zeroSkills = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat 0)--unitSkills :: Skills-unitSkills = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat 1)--addSkills :: Skills -> Skills -> Skills-addSkills = EM.unionWith (+)--scaleSkills :: Int -> Skills -> Skills-scaleSkills n = EM.map (n *)--instance Show Ability where-  show AbMove = "move"-  show AbMelee = "melee"-  show AbDisplace = "displace"-  show AbAlter = "alter tile"-  show AbWait = "wait"-  show AbMoveItem = "manage items"-  show AbProject = "fling"-  show AbApply = "activate"-  show AbTrigger = "trigger tile"--instance Binary Ability where-  put = putWord8 . toEnum . fromEnum-  get = fmap (toEnum . fromEnum) getWord8--instance Hashable Ability
− Game/LambdaHack/Common/Actor.hs 
@@ -1,262 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Actors in the game: heroes, monsters, etc. No operation in this module--- involves the 'State' or 'Action' type.-module Game.LambdaHack.Common.Actor-  ( -- * Actor identifiers and related operations-    ActorId, monsterGenChance, partActor, partPronoun-    -- * The@ Acto@r type-  , Actor(..), ResDelta(..)-  , deltaSerious, deltaMild, xM, minusM, minusTwoM, oneM-  , bspeed, actorTemplate, timeShiftFromSpeed, braced, waitedLastTurn-  , actorDying, actorNewBorn, hpTooLow, unoccupied-    -- * Assorted-  , ActorDict, smellTimeout, checkAdjacent-  , mapActorItems_, ppCStore, ppContainer-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.Int (Int64)-import Data.Ratio-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector---- | 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-  { -- The trunk of the actor's body (present also in @borgan@ or @beqp@)-    btrunk      :: !ItemId-    -- Presentation-  , bsymbol     :: !Char                 -- ^ individual map symbol-  , bname       :: !Text                 -- ^ individual name-  , bpronoun    :: !Text                 -- ^ individual pronoun-  , bcolor      :: !Color.Color          -- ^ individual map color-    -- Resources-  , btime       :: !Time                 -- ^ absolute time of next action-  , bhp         :: !Int64                -- ^ current hit points * 1M-  , bhpDelta    :: !ResDelta             -- ^ HP delta this turn * 1M-  , bcalm       :: !Int64                -- ^ current calm * 1M-  , bcalmDelta  :: !ResDelta             -- ^ calm delta this turn * 1M-    -- Location-  , bpos        :: !Point                -- ^ current position-  , boldpos     :: !Point                -- ^ previous position-  , blid        :: !LevelId              -- ^ current level-  , boldlid     :: !LevelId              -- ^ previous level-  , bfid        :: !FactionId            -- ^ faction the actor belongs to-  , boldfid     :: !FactionId            -- ^ previous faction of the actor-  , btrajectory :: !(Maybe ([Vector], Speed))  -- ^ trajectory the actor must-                                               --   travel and his travel speed-    -- Items-  , borgan      :: !ItemBag              -- ^ organs-  , beqp        :: !ItemBag              -- ^ personal equipment-  , binv        :: !ItemBag              -- ^ personal inventory-    -- Assorted-  , bwait       :: !Bool                 -- ^ is the actor waiting right now?-  , bproj       :: !Bool                 -- ^ is a projectile? (shorthand only,-                                         --   this can be deduced from bkind)-  }-  deriving (Show, Eq)--data ResDelta = ResDelta-  { resCurrentTurn  :: !Int64  -- ^ resource change this player turn-  , resPreviousTurn :: !Int64  -- ^ resource change last player turn-  }-  deriving (Show, Eq)--deltaSerious :: ResDelta -> Bool-deltaSerious ResDelta{..} = resCurrentTurn < minusM || resPreviousTurn < minusM--deltaMild :: ResDelta -> Bool-deltaMild ResDelta{..} = resCurrentTurn == minusM || resPreviousTurn == minusM--xM :: Int -> Int64-xM k = fromIntegral k * 1000000--minusM, minusTwoM, oneM :: Int64-minusM = xM (-1)-minusTwoM = xM (-2)-oneM = xM 1---- | 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 :: AbsDepth -> AbsDepth -> Int -> Rnd Bool-monsterGenChance (AbsDepth n) (AbsDepth depth) numMonsters =-  assert (depth > 0)-  -- Mimics @castDice@. On level 1, First 2 monsters appear fast.-  $ let scaledDepth = 5 * n `div` depth-    in chance $ 1%(fromIntegral (300 * (numMonsters - scaledDepth)) `max` 20)---- | The part of speech describing the actor.-partActor :: Actor -> MU.Part-partActor b = MU.Text $ bname b---- | The part of speech containing the actor pronoun.-partPronoun :: Actor -> MU.Part-partPronoun b = MU.Text $ bpronoun b---- Actor operations---- | A template for a new actor.-actorTemplate :: ItemId -> Char -> Text -> Text-              -> Color.Color -> Int64 -> Int64-              -> Point -> LevelId -> Time -> FactionId-              -> Actor-actorTemplate btrunk bsymbol bname bpronoun bcolor bhp bcalm-              bpos blid btime bfid =-  let btrajectory = Nothing-      boldpos = Point 0 0  -- make sure /= bpos, to tell it didn't switch level-      boldlid = blid-      beqp    = EM.empty-      binv    = EM.empty-      borgan  = EM.empty-      bwait   = False-      boldfid = bfid-      bhpDelta = ResDelta 0 0-      bcalmDelta = ResDelta 0 0-      bproj = False-  in Actor{..}--bspeed :: Actor -> [ItemFull] -> Speed-bspeed b activeItems =-  case btrajectory b of-    Nothing -> toSpeed $ max 1  -- avoid infinite wait-               $ sumSlotNoFilter Effect.EqpSlotAddSpeed activeItems-    Just (_, speed) -> speed---- | Add time taken by a single step at the actor's current speed.-timeShiftFromSpeed :: Actor -> [ItemFull] -> Time -> Time-timeShiftFromSpeed b activeItems time =-  let speed = bspeed b activeItems-      delta = ticksPerMeter speed-  in timeShift time delta---- | Whether an actor is braced for combat this clip.-braced :: Actor -> Bool-braced b = bwait b---- | The actor waited last turn.-waitedLastTurn :: Actor -> Bool-waitedLastTurn b = bwait b--actorDying :: Actor -> Bool-actorDying b = if bproj b-               then bhp b < 0-                    || maybe True (null . fst) (btrajectory b)-               else bhp b <= 0--actorNewBorn :: Actor -> Bool-actorNewBorn b = boldpos b == Point 0 0-                 && not (waitedLastTurn b)-                 && not (btime b < timeTurn)--hpTooLow :: Actor -> [ItemFull] -> Bool-hpTooLow b activeItems =-  let maxHP = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-  in bhp b <= oneM || 5 * bhp b < xM maxHP---- | Checks for the presence of actors in a position.--- Does not check if the tile is walkable.-unoccupied :: [Actor] -> Point -> Bool-unoccupied actors pos = all (\b -> bpos b /= pos) actors---- | How long until an actor's smell vanishes from a tile.-smellTimeout :: Delta Time-smellTimeout = timeDeltaScale (Delta timeTurn) 100---- | All actors on the level, indexed by actor identifier.-type ActorDict = EM.EnumMap ActorId Actor--checkAdjacent :: Actor -> Actor -> Bool-checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb)--mapActorItems_ :: Monad m => (ItemId -> Int -> m a) -> Actor -> m ()-mapActorItems_ f Actor{binv, beqp, borgan} = do-  let is = EM.assocs beqp ++ EM.assocs binv ++ EM.assocs borgan-  mapM_ (uncurry f) is--ppCStore :: CStore -> Text-ppCStore CGround = "on the ground"-ppCStore COrgan = "among organs"-ppCStore CEqp = "in equipment"-ppCStore CInv = "in inventory"-ppCStore CSha = "in shared stash"--ppContainer :: Container -> Text-ppContainer CFloor{} = "nearby"-ppContainer (CActor _ cstore) = ppCStore cstore-ppContainer CTrunk{} = "in our possession"--instance Binary Actor where-  put Actor{..} = do-    put btrunk-    put bsymbol-    put bname-    put bpronoun-    put bcolor-    put bhp-    put bhpDelta-    put bcalm-    put bcalmDelta-    put btrajectory-    put bpos-    put boldpos-    put blid-    put boldlid-    put binv-    put beqp-    put borgan-    put btime-    put bwait-    put bfid-    put boldfid-    put bproj-  get = do-    btrunk <- get-    bsymbol <- get-    bname <- get-    bpronoun <- get-    bcolor <- get-    bhp <- get-    bhpDelta <- get-    bcalm <- get-    bcalmDelta <- get-    btrajectory <- get-    bpos <- get-    boldpos <- get-    blid <- get-    boldlid <- get-    binv <- get-    beqp <- get-    borgan <- get-    btime <- get-    bwait <- get-    bfid <- get-    boldfid <- get-    bproj <- get-    return $! Actor{..}--instance Binary ResDelta where-  put ResDelta{..} = do-    put resCurrentTurn-    put resPreviousTurn-  get = do-    resCurrentTurn <- get-    resPreviousTurn <- get-    return $! ResDelta{..}
− Game/LambdaHack/Common/ActorState.hs 
@@ -1,359 +0,0 @@--- | 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.Common.ActorState-  ( fidActorNotProjAssocs, fidActorNotProjList-  , actorAssocsLvl, actorAssocs, actorList-  , actorRegularAssocsLvl, actorRegularAssocs, actorRegularList-  , bagAssocs, bagAssocsK, calculateTotal-  , sharedAllOwned, sharedAllOwnedFid-  , getCBag, getActorBag, getBodyActorBag, getActorAssocs-  , nearbyFreePoints, whereTo, getCarriedAssocs-  , posToActors, posToActor, getItemBody, memActor, getActorBody-  , tryFindHeroK, getLocalTime-  , itemPrice, calmEnough, hpEnough, regenCalmDelta-  , actorInAmbient, actorSkills, dispEnemy, radiusBlind-  , fullAssocs, itemToFull, goesIntoInv, eqpOverfull, storeFromC-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.Char as Char-import qualified Data.EnumMap.Strict as EM-import Data.Int (Int64)-import Data.List-import Data.Maybe--import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.TileKind--fidActorNotProjAssocs :: FactionId -> State -> [(ActorId, Actor)]-fidActorNotProjAssocs fid s =-  let f (_, b) = not (bproj b) && bfid b == fid-  in filter f $ EM.assocs $ sactorD s--fidActorNotProjList :: FactionId -> State -> [Actor]-fidActorNotProjList fid s = map snd $ fidActorNotProjAssocs fid s--actorAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict-               -> [(ActorId, Actor)]-actorAssocsLvl p lvl actorD =-  mapMaybe (\aid -> let b = actorD EM.! aid-                    in if p (bfid b)-                       then Just (aid, b)-                       else Nothing)-  $ concat $ EM.elems $ lprio lvl--actorAssocs :: (FactionId -> Bool) -> LevelId -> State-            -> [(ActorId, Actor)]-actorAssocs p lid s =-  actorAssocsLvl p (sdungeon s EM.! lid) (sactorD s)--actorList :: (FactionId -> Bool) -> LevelId -> State-          -> [Actor]-actorList p lid s = map snd $ actorAssocs p lid s--actorRegularAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict-                      -> [(ActorId, Actor)]-actorRegularAssocsLvl p lvl actorD =-  mapMaybe (\aid -> let b = actorD EM.! aid-                    in if not (bproj b) && bhp b > 0 && p (bfid b)-                       then Just (aid, b)-                       else Nothing)-  $ concat $ EM.elems $ lprio lvl--actorRegularAssocs :: (FactionId -> Bool) -> LevelId -> State-                   -> [(ActorId, Actor)]-actorRegularAssocs p lid s =-  actorRegularAssocsLvl p (sdungeon s EM.! lid) (sactorD s)--actorRegularList :: (FactionId -> Bool) -> LevelId -> State-                 -> [Actor]-actorRegularList p lid s = map snd $ actorRegularAssocs p lid s--getItemBody :: ItemId -> State -> Item-getItemBody iid s =-  fromMaybe (assert `failure` "item body not found"-                    `twith` (iid, s)) $ EM.lookup iid $ sitemD s--bagAssocs :: State -> ItemBag -> [(ItemId, Item)]-bagAssocs s bag =-  let iidItem iid = (iid, getItemBody iid s)-  in map iidItem $ EM.keys bag--bagAssocsK :: State -> ItemBag -> [(ItemId, (Item, Int))]-bagAssocsK s bag =-  let iidItem (iid, k) = (iid, (getItemBody iid s, k))-  in map iidItem $ EM.assocs bag---- | Finds an actor at a position on the current level.-posToActor :: Point -> LevelId -> State-           -> Maybe ((ActorId, Actor), [(ItemId, Item)])-posToActor pos lid s = listToMaybe $ posToActors pos lid s--posToActors :: Point -> LevelId -> State-            -> [((ActorId, Actor), [(ItemId, Item)])]-posToActors pos lid s =-  let as = actorAssocs (const True) lid s-      aps = filter (\(_, b) -> bpos b == pos) as-      g (aid, b) = ( (aid, b)-                   , bagAssocs s (binv b)-                     ++ bagAssocs s (beqp b)-                     ++ bagAssocs s (borgan b) )-      l = map g aps-  in assert (length l <= 1 || all (bproj . snd . fst) l-             `blame` "many actors at the same position" `twith` l)-     l--nearbyFreePoints :: (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State-                 -> [Point]-nearbyFreePoints f start lid s =-  let Kind.COps{cotile} = scops s-      lvl@Level{lxsize, lysize} = sdungeon s EM.! lid-      as = actorList (const True) lid s-      good p = f (lvl `at` p)-               && Tile.isWalkable cotile (lvl `at` p)-               && unoccupied as p-      ps = nub $ start : concatMap (vicinity lxsize lysize) ps-  in filter good ps---- | Calculate loot's worth for a faction of a given actor.-calculateTotal :: Actor -> State -> (ItemBag, Int)-calculateTotal body s =-  let bag = sharedAllOwned body s-      items = map (\(iid, k) -> (getItemBody iid s, k)) $ EM.assocs bag-  in (bag, sum $ map itemPrice items)--sharedInv :: Actor -> State -> ItemBag-sharedInv body s =-  let bs = fidActorNotProjList (bfid body) s-  in EM.unionsWith (+) $ map binv $ if null bs then [body] else bs--sharedEqp :: Actor -> State -> ItemBag-sharedEqp body s =-  let bs = fidActorNotProjList (bfid body) s-  in EM.unionsWith (+) $ map beqp $ if null bs then [body] else bs--sharedAllOwned :: Actor -> State -> ItemBag-sharedAllOwned body s =-  let shaBag = gsha $ sfactionD s EM.! bfid body-  in EM.unionsWith (+) [sharedEqp body s, sharedInv body s, shaBag]--sharedAllOwnedFid :: FactionId -> State -> ItemBag-sharedAllOwnedFid fid s =-  let shaBag = gsha $ sfactionD s EM.! fid-      bs = fidActorNotProjList fid s-  in EM.unionsWith (+) $ map binv bs ++ map beqp bs ++ [shaBag]---- | Price an item, taking count into consideration.-itemPrice :: (Item, Int) -> Int-itemPrice (item, jcount) =-  case jsymbol item of-    '$' -> jcount-    '*' -> jcount * 100-    _   -> 0---- * These few operations look at, potentially, all levels of the dungeon.---- | Tries to finds an actor body satisfying a predicate on any level.-tryFindActor :: State -> (Actor -> Bool) -> Maybe (ActorId, Actor)-tryFindActor s p =-  find (p . snd) $ EM.assocs $ sactorD s--tryFindHeroK :: State -> FactionId -> Int -> Maybe (ActorId, Actor)-tryFindHeroK s fact k =-  let c | k == 0          = '@'-        | k > 0 && k < 10 = Char.intToDigit k-        | otherwise       = assert `failure` "no digit" `twith` k-  in tryFindActor s (\body -> bsymbol body == c-                              && not (bproj body)-                              && bfid body == fact)---- | Compute the level identifier and starting position on the level,--- after a level change.-whereTo :: LevelId  -- ^ level of the stairs-        -> Point    -- ^ position of the stairs-        -> Int      -- ^ jump up this many levels-        -> Dungeon  -- ^ current game dungeon-        -> (LevelId, Point)-                    -- ^ target level and the position of its receiving stairs-whereTo lid pos k dungeon = assert (k /= 0) $-  let lvl = dungeon EM.! lid-      stairs = (if k < 0 then snd else fst) (lstair lvl)-      defaultStairs = 0  -- for ascending via, e.g., spells-      mindex = elemIndex pos stairs-      i = fromMaybe defaultStairs mindex-  in case ascendInBranch dungeon k lid of-    [] | isNothing mindex -> (lid, pos)  -- spell fizzles-    [] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos, k)-    ln : _ -> let lvlTgt = dungeon EM.! ln-                  stairsTgt = (if k < 0 then fst else snd) (lstair lvlTgt)-              in if length stairsTgt < i + 1-                 then assert `failure` "no stairs at index"-                             `twith` (lid, pos, k, ln, stairsTgt, i)-                 else (ln, stairsTgt !! i)---- * The operations below disregard levels other than the current.---- | Gets actor body from the current level. Error if not found.-getActorBody :: ActorId -> State -> Actor-getActorBody aid s =-  fromMaybe (assert `failure` "body not found" `twith` (aid, s))-  $ EM.lookup aid $ sactorD s--getCarriedAssocs :: Actor -> State -> [(ItemId, Item)]-getCarriedAssocs b s =-  bagAssocs s $ EM.unionsWith (const) [binv b, beqp b, borgan b]--getCBag :: Container -> State -> ItemBag-getCBag c s = case c of-  CFloor lid p -> sdungeon s EM.! lid `atI` p-  CActor aid cstore -> getActorBag aid cstore s-  CTrunk fid _ _ -> sharedAllOwnedFid fid s--getActorBag :: ActorId -> CStore -> State -> ItemBag-getActorBag aid cstore s =-  let b = getActorBody aid s-  in getBodyActorBag b cstore s--getBodyActorBag :: Actor -> CStore -> State -> ItemBag-getBodyActorBag b cstore s =-  case cstore of-    CGround -> sdungeon s EM.! blid b `atI` bpos b-    COrgan -> borgan b-    CEqp -> beqp b-    CInv -> binv b-    CSha -> gsha $ sfactionD s EM.! bfid b--getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)]-getActorAssocs aid cstore s = bagAssocs s $ getActorBag aid cstore s--getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, Int))]-getActorAssocsK aid cstore s = bagAssocsK s $ getActorBag aid cstore s---- | Checks if the actor is present on the current level.--- The order of argument here and in other functions is set to allow------ > b <- getsState (memActor a)-memActor :: ActorId -> LevelId -> State -> Bool-memActor aid lid s =-  maybe False ((== lid) . blid) $ EM.lookup aid $ sactorD s--calmEnough :: Actor -> [ItemFull] -> Bool-calmEnough b activeItems =-  let calmMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems-  in 2 * xM calmMax <= 3 * bcalm b--hpEnough :: Actor -> [ItemFull] -> Bool-hpEnough b activeItems =-  let hpMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-  in 2 * xM hpMax <= 3 * bhp b---- | Get current time from the dungeon data.-getLocalTime :: LevelId -> State -> Time-getLocalTime lid s = ltime $ sdungeon s EM.! lid--regenCalmDelta :: Actor -> [ItemFull] -> State -> Int64-regenCalmDelta b activeItems s =-  let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems-      calmIncr = oneM  -- normal rate of calm regen-      maxDeltaCalm = xM calmMax - bcalm b-      -- Worry actor by enemies felt (even if not seen)-      -- on the level within 3 tiles.-      fact = (EM.! bfid b) . sfactionD $ s-      allFoes = actorRegularList (isAtWar fact) (blid b) $ s-      isHeard body = not (waitedLastTurn body)-                     && chessDist (bpos b) (bpos body) <= 3-      noisyFoes = filter isHeard allFoes-  in if null noisyFoes-     then min calmIncr maxDeltaCalm-     else minusM  -- even if all calmness spent, keep informing the client--actorInAmbient :: Actor -> State -> Bool-actorInAmbient b s =-  let Kind.COps{cotile} = scops s-      lvl = (EM.! blid b) . sdungeon $ s-  in Tile.isLit cotile (lvl `at` bpos b)--actorSkills :: ActorId -> Maybe ActorId -> [ItemFull] -> State -> Ability.Skills-actorSkills aid mleader activeItems s =-  let Kind.COps{cofaction=Kind.Ops{okind}} = scops s-      body = getActorBody aid s-      fact = (EM.! bfid body) . sfactionD $ s-      factionSkills-        | Just aid == mleader = fSkillsLeader $ okind $ gkind fact-        | otherwise = fSkillsOther $ okind $ gkind fact-      itemSkills = sumSkills activeItems-  in itemSkills `Ability.addSkills` factionSkills---- Check whether an actor can displace an enemy. We assume they are adjacent.-dispEnemy :: ActorId -> ActorId -> [ItemFull] -> State -> Bool-dispEnemy source target activeItems s =-  let hasSupport b =-        let fact = (EM.! bfid b) . sfactionD $ s-            friendlyFid fid = fid == bfid b || isAllied fact fid-            sup = actorRegularList friendlyFid (blid b) s-        in any (adjacent (bpos b) . bpos) sup-      actorSk = actorSkills target (Just target) activeItems s-      sb = getActorBody source s-      tb = getActorBody target s-  in bproj tb-     || not (actorDying tb-             || braced tb-             || EM.findWithDefault 0 Ability.AbDisplace actorSk <= 0-                && EM.findWithDefault 0 Ability.AbMove actorSk <= 0-             || hasSupport sb && hasSupport tb)  -- solo actors are flexible---- | Determine if the sight radius is high enough to deem the actor capable--- of projecting items and similar activities. Otherwise, the actor--- is assumed to use a combination of peripherial vision, hearing, etc.,--- and not the actual focused, long-distance sight sense.-radiusBlind :: Int -> Bool-radiusBlind radius = radius < 4--fullAssocs :: Kind.COps -> Discovery -> DiscoAE-           -> ActorId -> [CStore] -> State-           -> [(ItemId, ItemFull)]-fullAssocs cops disco discoAE aid cstores s =-  let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores-      iToFull (iid, (item, k)) =-        (iid, itemToFull cops disco discoAE iid item k)-  in map iToFull allAssocs--itemToFull :: Kind.COps -> Discovery -> DiscoAE -> ItemId -> Item -> Int-           -> ItemFull-itemToFull Kind.COps{coitem=Kind.Ops{okind}}-           disco discoAE iid itemBase itemK =-  let itemDisco = case EM.lookup (jkindIx itemBase) disco of-        Nothing -> Nothing-        Just itemKindId -> Just ItemDisco{ itemKindId-                                         , itemKind = okind itemKindId-                                         , itemAE = EM.lookup iid discoAE }-  in ItemFull {..}--goesIntoInv :: Item -> Bool-goesIntoInv item = isNothing $ strengthEqpSlot item--eqpOverfull :: Actor -> Int -> Bool-eqpOverfull b n = let size = sum $ EM.elems $ beqp b-                  in assert (size <= 10 `blame` (b, n, size))-                     $ size + n > 10--storeFromC :: Container -> CStore-storeFromC c = case c of-  CFloor{} -> CGround-  CActor _ cstore -> cstore-  CTrunk{} -> CGround
− Game/LambdaHack/Common/ClientOptions.hs 
@@ -1,58 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Screen frames and animations.-module Game.LambdaHack.Common.ClientOptions-  ( DebugModeCli(..), defDebugModeCli-  ) where--import Data.Binary-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Faction--data DebugModeCli = DebugModeCli-  { sfont          :: !(Maybe String)-      -- ^ Font to use for the main game window.-  , smaxFps        :: !(Maybe Int)-      -- ^ Maximal frames per second.-      -- This is better low and fixed, to avoid jerkiness and delays-      -- that tell the player there are many intelligent enemies on the level.-      -- That's better than scaling AI sofistication down based-      -- on the FPS setting and machine speed.-  , snoDelay       :: !Bool-      -- ^ Don't maintain any requested delays between frames,-      -- e.g., for screensaver.-  , snoMore        :: !Bool-      -- ^ Auto-answer all prompts, e.g., for screensaver.-  , snoAnim        :: !(Maybe Bool)-      -- ^ Don't show any animations.-  , snewGameCli    :: !Bool-      -- ^ Start a new game, overwriting the save file.-  , sdifficultyCli :: !Int-      -- ^ The difficulty level for all UI clients.-  , ssavePrefixCli :: !(Maybe String)-      -- ^ Prefix of the save game file.-  , sfrontendStd   :: !Bool-      -- ^ Whether to use the stdout/stdin frontend for all clients.-  , sfrontendNull  :: !Bool-      -- ^ Whether to use void (no input/output) frontend for all clients.-  , sdbgMsgCli     :: !Bool-      -- ^ Show clients' internal debug messages.-  }-  deriving (Show, Eq, Generic)--instance Binary DebugModeCli--defDebugModeCli :: DebugModeCli-defDebugModeCli = DebugModeCli-  { sfont = Nothing-  , smaxFps = Nothing-  , snoDelay = False-  , snoMore = False-  , snoAnim = Nothing-  , snewGameCli = False-  , sdifficultyCli = difficultyDefault-  , ssavePrefixCli = Nothing-  , sfrontendStd = False-  , sfrontendNull = False-  , sdbgMsgCli = False-  }
− Game/LambdaHack/Common/Color.hs 
@@ -1,131 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Colours and text attributes.-module Game.LambdaHack.Common.Color-  ( -- * Colours-    Color(..), defBG, defFG, isBright, legalBG, darkCol, brightCol, stdCol-  , colorToRGB-    -- * Text attributes and the screen-  , Attr(..), defAttr, AttrChar(..)-  ) where--import Data.Binary-import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.))-import Data.Hashable (Hashable)-import GHC.Generics (Generic)---- TODO: since this type may be essential to speed, consider implementing--- it as an Int, with color numbered as they are on terminals, see--- http://www.haskell.org/haskellwiki/Performance/Data_types#Enumerations--- If we ever switch to 256 colours, the Int implementation or similar--- will be more natural, anyway.--- | Colours supported by the major frontends.-data Color =-    Black-  | Red-  | Green-  | Brown-  | Blue-  | Magenta-  | Cyan-  | White-  | BrBlack-  | BrRed-  | BrGreen-  | BrYellow-  | BrBlue-  | BrMagenta-  | BrCyan-  | BrWhite-  deriving (Show, Eq, Ord, Enum, Bounded, Generic)--instance Hashable Color---- | The default colours, to optimize attribute setting.-defBG, defFG :: Color-defBG = Black-defFG = White---- | Text attributes: foreground and backgroud colors.-data Attr = Attr-  { fg :: !Color  -- ^ foreground colour-  , bg :: !Color  -- ^ backgroud color-  }-  deriving (Show, Eq, Ord)--instance Enum Attr where-  fromEnum Attr{..} = fromEnum fg + unsafeShiftL (fromEnum bg) 8-  toEnum n = Attr (toEnum $ n .&. (2 ^ (8 :: Int)  - 1))-                  (toEnum $ unsafeShiftR n 8)---- | The default attribute, to optimize attribute setting.-defAttr :: Attr-defAttr = Attr defFG defBG--data AttrChar = AttrChar-  { acAttr :: !Attr-  , acChar :: !Char-  }-  deriving (Show, Eq, Ord)--instance Enum AttrChar where-  fromEnum AttrChar{..} = fromEnum acAttr + unsafeShiftL (fromEnum acChar) 16-  toEnum n = AttrChar (toEnum $ n .&. (2 ^ (16 :: Int) - 1))-                      (toEnum $ unsafeShiftR n 16)---- | A helper for the terminal frontends that display bright via bold.-isBright :: Color -> Bool-isBright c = c >= BrBlack---- | Due to the limitation of the curses library used in the curses frontend,--- only these are legal backgrounds.-legalBG :: [Color]-legalBG = [Black, White, Blue, Magenta]---- | Colour sets.-darkCol, brightCol, stdCol :: [Color]-darkCol   = [Red .. Cyan]-brightCol = [BrRed .. BrCyan]  -- BrBlack is not really that bright-stdCol    = darkCol ++ brightCol---- | Translationg to heavily modified Linux console color RGB values.-colorToRGB :: Color -> String-colorToRGB Black     = "#000000"-colorToRGB Red       = "#D50000"-colorToRGB Green     = "#00AA00"-colorToRGB Brown     = "#AA5500"-colorToRGB Blue      = "#203AF0"-colorToRGB Magenta   = "#AA00AA"-colorToRGB Cyan      = "#00AAAA"-colorToRGB White     = "#C5BCB8"-colorToRGB BrBlack   = "#6F5F5F"-colorToRGB BrRed     = "#FF5555"-colorToRGB BrGreen   = "#75FF45"-colorToRGB BrYellow  = "#FFE855"-colorToRGB BrBlue    = "#4090FF"-colorToRGB BrMagenta = "#FF77FF"-colorToRGB BrCyan    = "#60FFF0"-colorToRGB BrWhite   = "#FFFFFF"---- | For reference, the original Linux console colors.--- Good old retro feel and more useful than xterm (e.g. brown).-_olorToRGB :: Color -> String-_olorToRGB Black     = "#000000"-_olorToRGB Red       = "#AA0000"-_olorToRGB Green     = "#00AA00"-_olorToRGB Brown     = "#AA5500"-_olorToRGB Blue      = "#0000AA"-_olorToRGB Magenta   = "#AA00AA"-_olorToRGB Cyan      = "#00AAAA"-_olorToRGB White     = "#AAAAAA"-_olorToRGB BrBlack   = "#555555"-_olorToRGB BrRed     = "#FF5555"-_olorToRGB BrGreen   = "#55FF55"-_olorToRGB BrYellow  = "#FFFF55"-_olorToRGB BrBlue    = "#5555FF"-_olorToRGB BrMagenta = "#FF55FF"-_olorToRGB BrCyan    = "#55FFFF"-_olorToRGB BrWhite   = "#FFFFFF"--instance Binary Color where-  put = putWord8 . toEnum . fromEnum-  get = fmap (toEnum . fromEnum) getWord8
− Game/LambdaHack/Common/ContentDef.hs 
@@ -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 @ContentDef@ 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 @ContentDef@ instances, are defined in a directory--- of the game code proper, with names corresponding to their kinds.-module Game.LambdaHack.Common.ContentDef (ContentDef(..)) where--import Data.Text (Text)--import Game.LambdaHack.Common.Misc---- | The general type of a particular game content, e.g., item kinds.-data ContentDef a = ContentDef-  { 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-  }
− Game/LambdaHack/Common/Dice.hs 
@@ -1,195 +0,0 @@-{-# LANGUAGE DeriveGeneric, FlexibleInstances, TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Representation of dice for parameters scaled with current level depth.-module Game.LambdaHack.Common.Dice-  ( -- * Frequency distribution for casting dice scaled with level depth-    Dice, diceConst, diceLevel, diceScale, (|*|)-  , d, z, dl, zl, intToDice-  , maxDice, minDice, meanDice, reduceDice-    -- * Dice for rolling a pair of integer parameters representing coordinates.-  , DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY-  ) where--import Control.Applicative-import Data.Binary-import qualified Data.Char as Char-import Data.Hashable (Hashable)-import qualified Data.IntMap.Strict as IM-import Data.Ratio-import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Msg--type SimpleDice = Frequency Int--normalizeSimple :: SimpleDice -> SimpleDice-normalizeSimple fr = toFreq (nameFrequency fr)-                     $ map swap $ IM.toAscList $ IM.fromListWith (+)-                     $ map swap $ runFrequency fr---- Normalized mainly as an optimization, but it also makes many expected--- algeraic laws hold (wrt @Eq@), except for some laws about--- multiplication. We use @liftA2@ instead of @liftM2@, because it's probably--- faster in this case.-instance Num SimpleDice where-  fr1 + fr2 = normalizeSimple $ liftA2AdditiveName "+" (+) fr1 fr2-  fr1 * fr2 =-    let frRes = normalizeSimple $ do-          n <- fr1-          sum $ replicate n fr2  -- not commutative!-        nameRes =-          case T.uncons $ nameFrequency fr2 of-            _ | nameFrequency fr1 == "0" || nameFrequency fr2 == "0" -> "0"-            Just ('d', _) | T.all Char.isDigit $ nameFrequency fr1 ->-              nameFrequency fr1 <> nameFrequency fr2-            _ -> nameFrequency fr1 <+> "*" <+> nameFrequency fr2-    in renameFreq nameRes frRes-  fr1 - fr2 = normalizeSimple $ liftA2AdditiveName "-" (-) fr1 fr2-  negate = liftAName "-" negate-  abs = normalizeSimple . liftAName "abs" abs-  signum = normalizeSimple . liftAName "signum" signum-  fromInteger n = renameFreq (tshow n) $ pure $ fromInteger n--liftAName :: Text -> (Int -> Int) -> SimpleDice -> SimpleDice-liftAName name f fr =-  let frRes = liftA f fr-      nameRes = name <> " (" <> nameFrequency fr  <> ")"-  in renameFreq nameRes frRes--liftA2AdditiveName :: Text-                   -> (Int -> Int -> Int)-                   -> SimpleDice -> SimpleDice -> SimpleDice-liftA2AdditiveName name f fra frb =-  let frRes = liftA2 f fra frb-      nameRes =-        if nameFrequency fra == "0" then nameFrequency frb-        else if nameFrequency frb == "0" then nameFrequency fra-        else nameFrequency fra <+> name <+> nameFrequency frb-  in renameFreq nameRes frRes--dieSimple :: Int -> SimpleDice-dieSimple n = uniformFreq ("d" <> tshow n) [1..n]--zdieSimple :: Int -> SimpleDice-zdieSimple n = uniformFreq ("z" <> tshow n) [0..n-1]---- | Dice for parameters scaled with current level depth.--- To the result of rolling the first set of dice we add the second,--- scaled in proportion to current depth divided by maximal dungeon depth.--- The result if then multiplied by the scale --- to be used to ensure--- that dice results are multiples of, e.g., 10. The scale is set with @|*|@.-data Dice = Dice-  { diceConst :: SimpleDice-  , diceLevel :: SimpleDice-  , diceScale :: Int-  }-  deriving (Read, Eq, Ord, Generic)--instance Show Dice where-  show Dice{..} = T.unpack $-    let scaled = "scaled(" <> nameFrequency diceLevel <> ")"-    in (if nameFrequency diceLevel == "0" then nameFrequency diceConst-        else if nameFrequency diceConst == "0" then scaled-        else nameFrequency diceConst <+> "+" <+> scaled)-       <+> if diceScale == 1 then "" else "|*|" <+> tshow diceScale--instance Hashable Dice--instance Binary Dice--instance Num Dice where-  (Dice dc1 dl1 ds1) + (Dice dc2 dl2 ds2) =-    Dice (scaleFreq ds1 dc1 + scaleFreq ds2 dc2)-         (scaleFreq ds1 dl1 + scaleFreq ds2 dl2)-         1-  (Dice dc1 dl1 ds1) * (Dice dc2 dl2 ds2) =-    -- Hacky, but necessary (unless we forgo general multiplication and-    -- stick to multiplications by a scalar from the left and from the right).-    -- The pseudo-reasoning goes (remember the multiplication-    -- is not commutative, so we take all kinds of liberties):-    -- (dc1 + dl1 * l) * (dc2 + dl2 * l)-    -- = dc1 * dc2 + dc1 * dl2 * l + dl1 * l * dc2 + dl1 * l * dl2 * l-    -- = dc1 * dc2 + (dc1 * dl2) * l + (dl1 * dc2) * l + (dl1 * dl2) * l * l-    -- Now, we don't have a slot to put the coefficient of l * l into-    -- (and we don't know l yet, so we can't eliminate it by division),-    -- so we happily ignore it. Done. It works well in the cases that interest-    -- us, that is, multiplication by a scalar (a one-element frequency-    -- distribution) from any side, unscaled and scaled by level depth-    -- (but when we multiply two scaled scalars, we get 0).-    Dice (scaleFreq ds1 dc1 * scaleFreq ds2 dc2)-         (scaleFreq ds1 dc1 * scaleFreq ds2 dl2-          + scaleFreq ds1 dl1 * scaleFreq ds2 dc2)-         1-  (Dice dc1 dl1 ds1) - (Dice dc2 dl2 ds2) =-    Dice (scaleFreq ds1 dc1 - scaleFreq ds2 dc2)-         (scaleFreq ds1 dl1 - scaleFreq ds2 dl2)-         1-  negate = affectBothDice negate-  abs = affectBothDice abs-  signum = affectBothDice signum-  fromInteger n = Dice (fromInteger n) (fromInteger 0) 1--affectBothDice :: (SimpleDice -> SimpleDice) -> Dice -> Dice-affectBothDice f (Dice dc1 dl1 ds1) = Dice (f dc1) (f dl1) ds1--d :: Int -> Dice-d n = Dice (dieSimple n) (fromInteger 0) 1--z :: Int -> Dice-z n = Dice (zdieSimple n) (fromInteger 0) 1--dl :: Int -> Dice-dl n = Dice (fromInteger 0) (dieSimple n) 1--zl :: Int -> Dice-zl n = Dice (fromInteger 0) (zdieSimple n) 1--intToDice :: Int -> Dice-intToDice = fromInteger . fromIntegral--(|*|) :: Dice -> Int -> Dice-Dice dc1 dl1 ds1 |*| s2 = Dice dc1 dl1 (ds1 * s2)---- | Maximal value of dice. The scaled part taken assuming maximum level.--- Assumes the frequencies are not null.-maxDice :: Dice -> Int-maxDice Dice{..} = (maxFreq diceConst + maxFreq diceLevel) * diceScale---- | Minimal value of dice. The scaled part ignored.--- Assumes the frequencies are not null.-minDice :: Dice -> Int-minDice Dice{..} = minFreq diceConst * diceScale---- | Mean value of dice. The scaled part taken assuming average level.--- Assumes the frequencies are not null.-meanDice :: Dice -> Rational-meanDice Dice{..} = meanFreq diceConst * fromIntegral diceScale-                    + meanFreq diceLevel * fromIntegral diceScale * (1%2)--reduceDice :: Dice -> Maybe Int-reduceDice de = if minDice de == maxDice de then Just (minDice de) else Nothing---- | Dice for rolling a pair of integer parameters pertaining to,--- respectively, the X and Y cartesian 2D coordinates.-data DiceXY = DiceXY !Dice !Dice-  deriving (Show, Eq, Ord, Generic)--instance Hashable DiceXY--instance Binary DiceXY---- | Maximal value of DiceXY.-maxDiceXY :: DiceXY -> (Int, Int)-maxDiceXY (DiceXY x y) = (maxDice x, maxDice y)---- | Minimal value of DiceXY.-minDiceXY :: DiceXY -> (Int, Int)-minDiceXY (DiceXY x y) = (minDice x, minDice y)---- | Mean value of DiceXY.-meanDiceXY :: DiceXY -> (Rational, Rational)-meanDiceXY (DiceXY x y) = (meanDice x, meanDice y)
− Game/LambdaHack/Common/Effect.hs 
@@ -1,215 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveGeneric #-}--- | Effects of content on the game state. No operation in this module--- involves state or monad types.-module Game.LambdaHack.Common.Effect-  ( Effect(..), Aspect(..), ThrowMod(..), Feature(..), EqpSlot(..)-  , effectTrav, aspectTrav-  ) where--import qualified Control.Monad.State as St-import Data.Binary-import Data.Hashable (Hashable)-import Data.Text (Text)-import GHC.Generics (Generic)--import qualified Game.LambdaHack.Common.Ability as Ability-import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Misc---- TODO: document each constructor--- | Effects of items. Can be invoked by the item wielder to affect--- another actor or the wielder himself. Many occurences in the same item--- are possible.-data Effect a =-    NoEffect !Text-  | Hurt !Dice.Dice-  | Burn !Int-  | Explode !Text         -- ^ explode, producing this group of shrapnel-  | RefillHP !Int-  | RefillCalm !Int-  | Dominate-  | Impress-  | CallFriend !a-  | Summon !Freqs !a-  | CreateItem !a-  | Ascend !Int-  | Escape !Int           -- ^ the Int says if can be placed on last level, etc.-  | Paralyze !a-  | InsertMove !a-  | Teleport !a-  | PolyItem !CStore-  | Identify !CStore-  | SendFlying !ThrowMod-  | PushActor !ThrowMod-  | PullActor !ThrowMod-  | DropBestWeapon-  | DropEqp !Char !Bool   -- ^ symbol @' '@ means all, @True@ means hit on drop-  | ActivateInv !Char     -- ^ symbol @' '@ means all-  | ApplyPerfume-  | OneOf ![Effect a]-  | OnSmash !(Effect a)   -- ^ trigger if item smashed (not applied nor meleed)-  | TimedAspect !Int !(Aspect a)-                          -- ^ enable the aspect for k clips-  deriving (Show, Read, Eq, Ord, Generic, Functor)---- | Aspects of items. Additive (starting at 0) for all items wielded--- by an actor and affect the actor (except @Periodic@ that only affect--- the item and so is not additive).-data Aspect a =-    Periodic !a        -- ^ is activated this many times in 100-  | AddHurtMelee !a    -- ^ percentage damage bonus in melee-  | AddArmorMelee !a   -- ^ percentage armor bonus against melee-  | AddHurtRanged !a   -- ^ percentage damage bonus in ranged-  | AddArmorRanged !a  -- ^ percentage armor bonus against ranged-  | AddMaxHP !a        -- ^ maximal hp-  | AddMaxCalm !a      -- ^ maximal calm-  | AddSpeed !a        -- ^ speed in m/10s-  | AddSkills !Ability.Skills  -- ^ skills in particular abilities-  | AddSight !a        -- ^ FOV radius, where 1 means a single tile-  | AddSmell !a        -- ^ smell radius, where 1 means a single tile-  | AddLight !a        -- ^ light radius, where 1 means a single tile-  deriving (Show, Read, Eq, Ord, Generic, Functor)---- | Parameters modifying a throw. Not additive and don't start at 0.-data ThrowMod = ThrowMod-  { throwVelocity :: !Int  -- ^ fly with this percentage of base throw speed-  , throwLinger   :: !Int  -- ^ fly for this percentage of 2 turns-  }-  deriving (Show, Read, Eq, Ord, Generic)---- | Features of item. Affect only the item in question, not the actor,--- and so not additive in any sense.-data Feature =-    ChangeTo !Text           -- ^ change to this group when altered-  | Fragile                  -- ^ break even when not hitting an enemy-  | Durable                  -- ^ don't break even hitting or applying-  | ToThrow !ThrowMod        -- ^ parameters modifying a throw-  | Identified               -- ^ the item starts identified-  | Applicable               -- ^ AI and uI flag: consider applying-  | EqpSlot !EqpSlot !Text   -- ^ AI and uI flag: goes to inventory-  | Precious                 -- ^ AI and UI flag: careful, can be precious;-                             --   don't risk identifying by use-  deriving (Show, Eq, Ord, Generic)--data EqpSlot =-    EqpSlotPeriodic-  | EqpSlotAddHurtMelee-  | EqpSlotAddArmorMelee-  | EqpSlotAddHurtRanged-  | EqpSlotAddArmorRanged-  | EqpSlotAddMaxHP-  | EqpSlotAddMaxCalm-  | EqpSlotAddSpeed-  | EqpSlotAddSkills-  | EqpSlotAddSight-  | EqpSlotAddSmell-  | EqpSlotAddLight-  | EqpSlotWeapon-  deriving (Show, Eq, Ord, Generic)--instance Hashable a => Hashable (Effect a)--instance Hashable a => Hashable (Aspect a)--instance Hashable ThrowMod--instance Hashable Feature--instance Hashable EqpSlot--instance Binary a => Binary (Effect a)--instance Binary a => Binary (Aspect a)--instance Binary ThrowMod--instance Binary Feature--instance Binary EqpSlot---- TODO: Traversable?--- | Transform an effect using a stateful function.-effectTrav :: Effect a -> (a -> St.State s b) -> St.State s (Effect b)-effectTrav (NoEffect t) _ = return $! NoEffect t-effectTrav (RefillHP p) _ = return $! RefillHP p-effectTrav (Hurt dice) _ = return $! Hurt dice-effectTrav (RefillCalm p) _ = return $! RefillCalm p-effectTrav Dominate _ = return Dominate-effectTrav Impress _ = return Impress-effectTrav (CallFriend a) f = do-  b <- f a-  return $! CallFriend b-effectTrav (Summon freqs a) f = do-  b <- f a-  return $! Summon freqs b-effectTrav (CreateItem a) f = do-  b <- f a-  return $! CreateItem b-effectTrav ApplyPerfume _ = return ApplyPerfume-effectTrav (Burn p) _ = return $! Burn p-effectTrav (Ascend p) _ = return $! Ascend p-effectTrav (Escape p) _ = return $! Escape p-effectTrav (Paralyze a) f = do-  b <- f a-  return $! Paralyze b-effectTrav (InsertMove a) f = do-  b <- f a-  return $! InsertMove b-effectTrav DropBestWeapon _ = return DropBestWeapon-effectTrav (DropEqp symbol hit) _ = return $! DropEqp symbol hit-effectTrav (SendFlying tmod) _ = return $! SendFlying tmod-effectTrav (PushActor tmod) _ = return $! PushActor tmod-effectTrav (PullActor tmod) _ = return $! PullActor tmod-effectTrav (Teleport a) f = do-  b <- f a-  return $! Teleport b-effectTrav (PolyItem cstore) _ = return $! PolyItem cstore-effectTrav (Identify cstore) _ = return $! Identify cstore-effectTrav (ActivateInv symbol) _ = return $! ActivateInv symbol-effectTrav (OneOf la) f = do-  lb <- mapM (\a -> effectTrav a f) la-  return $! OneOf lb-effectTrav (OnSmash effa) f = do-  effb <- effectTrav effa f-  return $! OnSmash effb-effectTrav (Explode t) _ = return $! Explode t-effectTrav (TimedAspect k asp) f = do-  asp2 <- aspectTrav asp f-  return $! TimedAspect k asp2---- | Transform an aspect using a stateful function.-aspectTrav :: Aspect a -> (a -> St.State s b) -> St.State s (Aspect b)-aspectTrav (Periodic a) f = do-  b <- f a-  return $! Periodic b-aspectTrav (AddMaxHP a) f = do-  b <- f a-  return $! AddMaxHP b-aspectTrav (AddMaxCalm a) f = do-  b <- f a-  return $! AddMaxCalm b-aspectTrav (AddSpeed a) f = do-  b <- f a-  return $! AddSpeed b-aspectTrav (AddSkills as) _ = return $! AddSkills as-aspectTrav (AddHurtMelee a) f = do-  b <- f a-  return $! AddHurtMelee b-aspectTrav (AddHurtRanged a) f = do-  b <- f a-  return $! AddHurtRanged b-aspectTrav (AddArmorMelee a) f = do-  b <- f a-  return $! AddArmorMelee b-aspectTrav (AddArmorRanged a) f = do-  b <- f a-  return $! AddArmorRanged b-aspectTrav (AddSight a) f = do-  b <- f a-  return $! AddSight b-aspectTrav (AddSmell a) f = do-  b <- f a-  return $! AddSmell b-aspectTrav (AddLight a) f = do-  b <- f a-  return $! AddLight b
− Game/LambdaHack/Common/EffectDescription.hs 
@@ -1,162 +0,0 @@--- | Description of effects. No operation in this module--- involves state or monad types.-module Game.LambdaHack.Common.EffectDescription-  ( effectToSuffix, aspectToSuffix, featureToSuff-  , kindEffectToSuffix, kindAspectToSuffix-  ) where--import Control.Exception.Assert.Sugar-import qualified Control.Monad.State as St-import qualified Data.EnumMap.Strict as EM-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU---- import Game.LambdaHack.Common.Actor (ppCStore)-import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Time---- | Suffix to append to a basic content name if the content causes the effect.-effectToSuff :: (Show a, Ord a, Num a)-             => Effect a -> (a -> Text) -> (a -> Maybe Int) -> Text-effectToSuff effect f g =-  case ( St.evalState (effectTrav effect $ return . f) ()-       , St.evalState (effectTrav effect $ return . g) () ) of-    (NoEffect t, _) -> t-    (RefillHP p, _) | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)-    (RefillHP 0, _) -> assert `failure` effect-    (RefillHP p, _) -> "of wounding" <+> wrapInParens (affixBonus p)-    (Hurt dice, _) -> wrapInParens (tshow dice)-    (RefillCalm p, _) | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p)-    (RefillCalm 0, _) -> assert `failure` effect-    (RefillCalm p, _) -> "of dismaying" <+> wrapInParens (affixBonus p)-    (Dominate, _) -> "of domination"-    (Impress, _) -> "of impression"-    (_, CallFriend (Just 1)) -> "of aid calling"-    (CallFriend t, _) -> "of aid calling"-                         <+> wrapInParens (dropPlus t <+> "friends")-    (_, Summon _freqs (Just 1)) -> "of summoning"  -- TODO-    (Summon _freqs t, _) -> "of summoning"-                            <+> wrapInParens (dropPlus t <+> "actors")-    (_, CreateItem (Just 1)) -> "of uncovering"-    (CreateItem t, _) -> "of uncovering"-                         <+> wrapInParens (dropPlus t <+> "items")-    (ApplyPerfume, _) -> "of smell removal"-    (Burn p, _) | p <= 0 -> assert `failure` effect-    (Burn p, _) -> wrapInParens (makePhrase [MU.CarWs p "burn"])-    (Ascend 1, _) -> "of ascending"-    (Ascend p, _) | p > 0 ->-      "of ascending" <+> wrapInParens (tshow p <+> "levels")-    (Ascend 0, _) -> assert `failure` effect-    (Ascend (-1), _) -> "of descending"-    (Ascend p, _) ->-      "of descending" <+> wrapInParens (tshow (-p) <+> "levels")-    (Escape{}, _) -> "of escaping"-    (_, Paralyze Nothing) -> "of paralysis (? clips)"-    (_, Paralyze (Just p)) ->-      let clipInTurn = timeTurn `timeFit` timeClip-          seconds = 0.5 * fromIntegral p / fromIntegral clipInTurn :: Double-      in "of paralysis" <+> wrapInParens (tshow seconds <> "s")-    (_, InsertMove Nothing) ->-      "of speed surge (? moves)"-    (_, InsertMove (Just p)) ->-      "of speed surge" <+> wrapInParens (makePhrase [MU.CarWs p "move"])-    (DropBestWeapon, _) -> "of disarming"-    (DropEqp ' ' False, _) -> "of equipment drop"-    (DropEqp symbol False, _) -> "of drop '" <> T.singleton symbol <> "'"-    (DropEqp ' ' True, _) -> "of equipment smash"-    (DropEqp symbol True, _) -> "of smash '" <> T.singleton symbol <> "'"-    (SendFlying tmod, _) -> "of impact" <+> tmodToSuff "" tmod-    (PushActor tmod, _) -> "of pushing" <+> tmodToSuff "" tmod-    (PullActor tmod, _) -> "of pulling" <+> tmodToSuff "" tmod-    (_, Teleport (Just p)) | p <= 1  -> assert `failure` effect-    (Teleport t, Teleport (Just p)) | p <= 9  ->-      "of blinking" <+> wrapInParens (dropPlus t <+> "steps")-    (Teleport t, _)->-      "of teleport" <+> wrapInParens (dropPlus t <+> "steps")-    (PolyItem _cstore, _) -> "of repurpose"  -- <+> ppCStore cstore-    (Identify _cstore, _) -> "of identify"  -- <+> ppCStore cstore-    (ActivateInv ' ', _) -> "of inventory burst"-    (ActivateInv symbol, _) -> "of burst '" <> T.singleton symbol <> "'"-    (Explode _, _) -> "of explosion"  -- TODO: first word + explosion? nothing?-    (OneOf l, _) ->-      let subject = if length l <= 5 then "marvel" else "wonder"-      in makePhrase ["of", MU.CardinalWs (length l) subject]-    (OnSmash _, _) -> ""  -- conditional effect, TMI-    (TimedAspect _ aspect, _) -> "keep (" <> rawAspectToSuff aspect <> ")"-    (effectF, effectG) -> assert `failure` (effect, effectF, effectG)--tmodToSuff :: Text -> ThrowMod -> Text-tmodToSuff verb ThrowMod{..} =-  let vSuff | throwVelocity == 100 = ""-            | otherwise = "v=" <> tshow throwVelocity <> "%"-      tSuff | throwLinger == 100 = ""-            | otherwise = "t=" <> tshow throwLinger <> "%"-  in if vSuff == "" && tSuff == "" then ""-     else verb <+> "with" <+> vSuff <+> tSuff--aspectToSuff :: Show a => Aspect a -> (a -> Text) -> Text-aspectToSuff aspect f =-  rawAspectToSuff $ St.evalState (aspectTrav aspect $ return . f) ()--rawAspectToSuff :: Aspect Text -> Text-rawAspectToSuff aspect =-  case aspect of-    Periodic t -> wrapInParens $ dropPlus t <+> "in 100"-    AddMaxHP t -> wrapInParens $ t <+> "HP"-    AddMaxCalm t -> wrapInParens $ t <+> "Calm"-    AddSpeed t -> wrapInParens $ t <+> "speed"-    AddSkills p -> wrapInParens $ "+" <+> tshow (EM.toList p)-    AddHurtMelee t -> wrapInParens $ t <> "% melee"-    AddHurtRanged  t -> wrapInParens $ t <> "% ranged"-    AddArmorMelee t -> "[" <> t <> "%]"-    AddArmorRanged t -> "{" <> t <> "%}"-    AddSight t -> wrapInParens $ t <+> "sight"-    AddSmell t -> wrapInParens $ t <+> "smell"-    AddLight t -> wrapInParens $ t <+> "light"--featureToSuff :: Feature -> Text-featureToSuff feat =-  case feat of-    ChangeTo t -> wrapInChevrons $ "changes to" <+> t-    Fragile -> wrapInChevrons $ "fragile"-    Durable -> wrapInChevrons $ "durable"-    ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod-    Identified -> ""-    Applicable -> ""-    EqpSlot{} -> ""-    Precious -> ""--dropPlus :: Text -> Text-dropPlus = T.dropWhile (`elem` ['+', '-'])--effectToSuffix :: Effect Int -> Text-effectToSuffix effect = effectToSuff effect affixBonus Just--aspectToSuffix :: Aspect Int -> Text-aspectToSuffix aspect = aspectToSuff aspect affixBonus--affixBonus :: Int -> Text-affixBonus p = case compare p 0 of-  EQ -> ""-  LT -> tshow p-  GT -> "+" <> tshow p--wrapInParens :: Text -> Text-wrapInParens "" = ""-wrapInParens t = "(" <> t <> ")"--wrapInChevrons :: Text -> Text-wrapInChevrons "" = ""-wrapInChevrons t = "<" <> t <> ">"--affixDice :: Dice.Dice -> Text-affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d--kindEffectToSuffix :: Effect Dice.Dice -> Text-kindEffectToSuffix effect = effectToSuff effect affixDice Dice.reduceDice--kindAspectToSuffix :: Aspect Dice.Dice -> Text-kindAspectToSuffix aspect = aspectToSuff aspect affixDice
− Game/LambdaHack/Common/Faction.hs 
@@ -1,171 +0,0 @@--- | Factions taking part in the game: e.g., two human players controlling--- the hero faction battling the monster and the animal factions.-module Game.LambdaHack.Common.Faction-  ( FactionId, FactionDict, Faction(..), Diplomacy(..), Outcome(..), Status(..)-  , isHeroFact, isCivilianFact, isHorrorFact, isSpawnFact, isSummonFact-  , isAllMoveFact, keepArenaFact, isAtWar, isAllied-  , difficultyBound, difficultyDefault, difficultyCoeff-  ) where--import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.Text (Text)--import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind---- | All factions in the game, indexed by faction identifier.-type FactionDict = EM.EnumMap FactionId Faction--data Faction = Faction-  { gkind    :: !(Kind.Id FactionKind)  -- ^ the kind of the faction-  , gname    :: !Text                   -- ^ individual name-  , gcolor   :: !Color.Color            -- ^ color of actors or their frames-  , gplayer  :: !Player                 -- ^ the player spec for this faction-  , gdipl    :: !Dipl                   -- ^ diplomatic mode-  , gquit    :: !(Maybe Status)         -- ^ cause of game end/exit-  , gleader  :: !(Maybe ActorId)        -- ^ the leader of the faction, if any-  , gsha     :: !ItemBag                -- ^ faction's shared inventory-  , gvictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ members killed-  }-  deriving (Show, Eq)---- | Diplomacy states. Higher overwrite lower in case of assymetric content.-data Diplomacy =-    Unknown-  | Neutral-  | Alliance-  | War-  deriving (Show, Eq, Ord, Enum)--type Dipl = EM.EnumMap FactionId Diplomacy---- | Outcome of a game.-data Outcome =-    Killed    -- ^ the faction was eliminated-  | Defeated  -- ^ the faction lost the game in another way-  | Camping   -- ^ game is supended-  | Conquer   -- ^ the player won by eliminating all rivals-  | Escape    -- ^ the player escaped the dungeon alive-  | Restart   -- ^ game is restarted-  deriving (Show, Eq, Ord, Enum)---- | Current game status.-data Status = Status-  { stOutcome :: !Outcome  -- ^ current game outcome-  , stDepth   :: !Int      -- ^ depth of the final encounter-  , stInfo    :: !Text     -- ^ extra information-  }-  deriving (Show, Eq, Ord)---- | Tell whether the faction consists of heroes.-isHeroFact :: Faction -> Bool-isHeroFact fact = playerIsHero (gplayer fact)---- | Tell whether the faction consists of human civilians.-isCivilianFact :: Kind.COps -> Faction -> Bool-isCivilianFact Kind.COps{cofaction=Kind.Ops{okind}} fact =-  let kind = okind (gkind fact)-  in maybe False (> 0) $ lookup "civilian" $ ffreq kind---- | Tell whether the faction consists of summoned horrors only.-isHorrorFact :: Kind.COps -> Faction -> Bool-isHorrorFact Kind.COps{cofaction=Kind.Ops{okind}} fact =-  let kind = okind (gkind fact)-  in maybe False (> 0) $ lookup "horror" $ ffreq kind---- | Tell whether the faction is considered permanent dungeon dwellers--- (normally these are just spawning factions, but there are exceptions).-isSpawnFact :: Faction -> Bool-isSpawnFact fact = playerIsSpawn (gplayer fact)---- | Tell whether actors of the faction can be summoned by items, etc.-isSummonFact :: Kind.COps -> Faction -> Bool-isSummonFact Kind.COps{cofaction=Kind.Ops{okind}} fact =-  let kind = okind (gkind fact)-  in maybe False (> 0) $ lookup "summon" $ ffreq kind---- | Tell whether all moving actors of the factions can move at once.-isAllMoveFact :: Kind.COps -> Faction -> Bool-isAllMoveFact Kind.COps{cofaction=Kind.Ops{okind}} fact =-  let kind = okind (gkind fact)-      skillsLeader = fSkillsLeader kind-      skillsOther = fSkillsOther kind-  in EM.findWithDefault 0 Ability.AbMove skillsLeader > 0-     && EM.findWithDefault 0 Ability.AbMove skillsOther > 0---- | Tell whether a faction that we know is still in game, keeps arena.--- Such factions win if they can escape the dungeon.--- Keeping arena means, if the faction is still in game,--- it always has a leader in the dungeon somewhere.--- So, leaderless factions and spawner factions do not keep an arena,--- even though the latter usually has a leader for most of the game.-keepArenaFact :: Faction -> Bool-keepArenaFact fact = playerLeader (gplayer fact) && not (isSpawnFact fact)---- | Check if factions are at war. Assumes symmetry.-isAtWar :: Faction -> FactionId -> Bool-isAtWar fact fid = War == EM.findWithDefault Unknown fid (gdipl fact)---- | Check if factions are allied. Assumes symmetry.-isAllied :: Faction -> FactionId -> Bool-isAllied fact fid = Alliance == EM.findWithDefault Unknown fid (gdipl fact)--difficultyBound :: Int-difficultyBound = 9--difficultyDefault :: Int-difficultyDefault = (1 + difficultyBound) `div` 2---- The function is its own inverse.-difficultyCoeff :: Int -> Int-difficultyCoeff n = difficultyDefault - n--instance Binary Faction where-  put Faction{..} = do-    put gkind-    put gname-    put gcolor-    put gplayer-    put gdipl-    put gquit-    put gleader-    put gsha-    put gvictims-  get = do-    gkind <- get-    gname <- get-    gcolor <- get-    gplayer <- get-    gdipl <- get-    gquit <- get-    gleader <- get-    gsha <- get-    gvictims <- get-    return $! Faction{..}--instance Binary Diplomacy where-  put = putWord8 . toEnum . fromEnum-  get = fmap (toEnum . fromEnum) getWord8--instance Binary Outcome where-  put = putWord8 . toEnum . fromEnum-  get = fmap (toEnum . fromEnum) getWord8--instance Binary Status where-  put Status{..} = do-    put stOutcome-    put stDepth-    put stInfo-  get = do-    stOutcome <- get-    stDepth <- get-    stInfo <- get-    return $! Status{..}
− Game/LambdaHack/Common/Feature.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Terrain tile features.-module Game.LambdaHack.Common.Feature-  ( Feature(..)-  ) where--import Data.Binary-import Data.Hashable (Hashable)-import Data.Text (Text)-import GHC.Generics (Generic)--import qualified Game.LambdaHack.Common.Effect as Effect---- | All possible terrain tile features.-data Feature =-    Cause !(Effect.Effect Int)  -- ^ causes the effect when triggered-  | OpenTo !Text         -- ^ goes from a closed to an open tile when altered-  | CloseTo !Text        -- ^ goes from an open to a closed tile when altered-  | ChangeTo !Text       -- ^ alters tile, but does not change walkability-  | HideAs !Text         -- ^ when hidden, looks as a tile of the group-  | RevealAs !Text       -- ^ if secret, can be revealed to belong to the group--  | Walkable             -- ^ actors can walk through-  | Clear                -- ^ actors can see through-  | Dark                 -- ^ is not lit with an ambient shine-  | Suspect              -- ^ may not be what it seems (clients only)-  | Aura !(Effect.Effect Int)  -- ^ sustains the effect continuously, TODO-  | Impenetrable         -- ^ can never be excavated nor seen through--  | OftenItem            -- ^ initial items often generated there-  | OftenActor           -- ^ initial actors and stairs often generated there-  | NoItem               -- ^ no items ever generated there-  | NoActor              -- ^ no actors nor stairs ever generated there-  | Trail                -- ^ used for visible trails throughout the level-  deriving (Show, Read, Eq, Ord, Generic)--instance Binary Feature--instance Hashable Feature
− Game/LambdaHack/Common/File.hs 
@@ -1,86 +0,0 @@--- | Saving/loading with serialization and compression.-module Game.LambdaHack.Common.File-  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir-  ) where--import qualified Codec.Compression.Zlib as Z-import qualified Control.Exception as Ex hiding (handle)-import Control.Monad-import Data.Binary-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Char as Char-import System.Directory-import System.Environment-import System.FilePath-import System.IO---- | Serialize, compress and save data.--- Note that LBS.writeFile opens the file in binary mode.-encodeData :: Binary a => FilePath -> a -> IO ()-encodeData f a = do-  let tmpPath = f <.> "tmp"-  Ex.bracketOnError-    (openBinaryFile tmpPath WriteMode)-    (\h -> hClose h >> removeFile tmpPath)-    (\h -> do-       LBS.hPut h . Z.compress . encode $ a-       hClose h-       renameFile tmpPath f-    )---- | Serialize, compress and save data with an EOF marker.--- The @OK@ is used as an EOF marker to ensure any apparent problems with--- corrupted files are reported to the user ASAP.-encodeEOF :: Binary a => FilePath -> a -> IO ()-encodeEOF f a = encodeData f (a, "OK" :: String)---- | Read and decompress the serialized data.-strictReadSerialized :: FilePath -> IO LBS.ByteString-strictReadSerialized f =-  withBinaryFile f ReadMode $ \ h -> do-    c <- LBS.hGetContents h-    let d = Z.decompress c-    LBS.length d `seq` return d---- | Read, decompress and deserialize data.-strictDecodeData :: Binary a => FilePath -> IO a-strictDecodeData = fmap decode . strictReadSerialized---- | Read, decompress and deserialize data with an EOF marker.--- The @OK@ EOF marker ensures any easily detectable file corruption--- is discovered and reported before the function returns.-strictDecodeEOF :: Binary a => FilePath -> IO a-strictDecodeEOF f = do-  (a, n) <- strictDecodeData f-  if n == ("OK" :: String)-    then return $! a-    else error $ "Fatal error: corrupted file " ++ f---- | Try to create a directory, if it doesn't exist. Terminate the program--- with an exception if the directory does not exist, but can't be created.-tryCreateDir :: FilePath -> IO ()-tryCreateDir dir = do-  dirExists <- doesDirectoryExist dir-  unless dirExists $ createDirectory dir---- | Try to copy over data files, if not already there.-tryCopyDataFiles :: FilePath-                 -> (FilePath -> IO FilePath)-                 -> [(FilePath, FilePath)]-                 -> IO ()-tryCopyDataFiles dataDir pathsDataFile files =-  let cpFile (fin, fout) = do-        pathsDataIn <- pathsDataFile fin-        bIn <- doesFileExist pathsDataIn-        let pathsDataOut = dataDir </> fout-        bOut <- doesFileExist pathsDataOut-        when (not bOut && bIn) $ copyFile pathsDataIn pathsDataOut-  in mapM_ cpFile files---- | Personal data directory for the game. Depends on the OS and the game,--- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.-appDataDir :: IO FilePath-appDataDir = do-  progName <- getProgName-  let name = takeWhile Char.isAlphaNum progName-  getAppUserDataDirectory name
− Game/LambdaHack/Common/Flavour.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | The appearance of in-game items, as communicated to the player.-module Game.LambdaHack.Common.Flavour-  ( -- * The @Flavour@ type-    Flavour-  , -- * Constructors-    zipPlain, zipFancy, stdFlav-  , -- * Accessors-    flavourToColor, flavourToName-    -- * Assorted-  , colorToTeamName, colorToPlainName, colorToFancyName-  ) where--import Data.Binary-import Data.Hashable (Hashable)-import Data.Text (Text)-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Color---- TODO: add more variety, as the number of items increases--- | The type of item flavours.-data Flavour = Flavour-  { fancyName :: !Bool   -- ^ should the colour description be fancy or plain-  , baseColor :: !Color  -- ^ the colour of the flavour-  }-  deriving (Show, Eq, Ord, Generic)--instance Hashable Flavour--instance Binary Flavour---- | Turn a colour set into a flavour set.-zipPlain, zipFancy :: [Color] -> [Flavour]-zipPlain = map (Flavour False)-zipFancy = map (Flavour True)---- | The standard full set of flavours.-stdFlav :: [Flavour]-stdFlav = zipPlain stdCol ++ zipFancy stdCol---- | Get the underlying base colour of a flavour.-flavourToColor :: Flavour -> Color-flavourToColor Flavour{baseColor} = baseColor---- | Construct the full name of a flavour.-flavourToName :: Flavour -> Text-flavourToName Flavour{..} | fancyName = colorToFancyName baseColor-flavourToName Flavour{..}             = colorToPlainName baseColor---- | Human-readable names, for item colors. The simple set.-colorToPlainName :: Color -> Text-colorToPlainName Black     = "black"-colorToPlainName Red       = "red"-colorToPlainName Green     = "green"-colorToPlainName Brown     = "brown"-colorToPlainName Blue      = "blue"-colorToPlainName Magenta   = "purple"-colorToPlainName Cyan      = "cyan"-colorToPlainName White     = "ivory"-colorToPlainName BrBlack   = "gray"-colorToPlainName BrRed     = "coral"-colorToPlainName BrGreen   = "lime"-colorToPlainName BrYellow  = "yellow"-colorToPlainName BrBlue    = "azure"-colorToPlainName BrMagenta = "pink"-colorToPlainName BrCyan    = "aquamarine"-colorToPlainName BrWhite   = "white"---- | Human-readable names, for item colors. The fancy set.-colorToFancyName :: Color -> Text-colorToFancyName Black     = "smoky-black"-colorToFancyName Red       = "apple-red"-colorToFancyName Green     = "forest-green"-colorToFancyName Brown     = "mahogany"-colorToFancyName Blue      = "royal-blue"-colorToFancyName Magenta   = "indigo"-colorToFancyName Cyan      = "teal"-colorToFancyName White     = "silver-gray"-colorToFancyName BrBlack   = "charcoal"-colorToFancyName BrRed     = "salmon"-colorToFancyName BrGreen   = "emerald"-colorToFancyName BrYellow  = "amber"-colorToFancyName BrBlue    = "sky-blue"-colorToFancyName BrMagenta = "magenta"-colorToFancyName BrCyan    = "turquoise"-colorToFancyName BrWhite   = "ghost-white"---- | Simple names for team colors (bright colours preferred).-colorToTeamName :: Color -> Text-colorToTeamName BrRed     = "red"-colorToTeamName BrGreen   = "green"-colorToTeamName BrYellow  = "yellow"-colorToTeamName BrBlue    = "blue"-colorToTeamName BrMagenta = "pink"-colorToTeamName BrCyan    = "cyan"-colorToTeamName BrWhite   = "white"-colorToTeamName c = colorToFancyName c
− Game/LambdaHack/Common/Frequency.hs 
@@ -1,126 +0,0 @@-{-# LANGUAGE DeriveFoldable, DeriveGeneric, DeriveTraversable #-}--- | A list of items with relative frequencies of appearance.-module Game.LambdaHack.Common.Frequency-  ( -- * The @Frequency@ type-    Frequency-    -- * Construction-  , uniformFreq, toFreq-    -- * Transformation-  , scaleFreq, renameFreq, setFreq-    -- * Consumption-  , nullFreq, runFrequency, nameFrequency-  , maxFreq, minFreq, meanFreq-  ) where--import Control.Applicative-import Control.Arrow (first, second)-import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Binary-import Data.Foldable (Foldable)-import Data.Hashable (Hashable)-import Data.Ratio-import Data.Text (Text)-import Data.Traversable (Traversable)-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Msg---- TODO: do not expose runFrequency--- | The frequency distribution type. Not normalized (operations may--- or may not group the same elements and sum their frequencies).------ The @Eq@ instance compares raw representations, not relative,--- normalized frequencies, so operations don't need to preserve--- the expected equalities, unless they do some kind of normalization--- (see 'Dice').-data Frequency a = Frequency-  { nameFrequency :: Text         -- ^ short description for debug, etc.;-                                  --   keep it lazy, because it's rarely used-  , runFrequency  :: ![(Int, a)]  -- ^ give acces to raw frequency values-  }-  deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic)--instance Monad Frequency where-  {-# INLINE return #-}-  return x = Frequency "return" [(1, x)]-  Frequency name xs >>= f =-    Frequency ("bind (" <> name <> ")")-              [ (p * q, y) | (p, x) <- xs-                           , (q, y) <- runFrequency (f x) ]--instance Functor Frequency where-  fmap f (Frequency name xs) = Frequency name (map (second f) xs)--instance Applicative Frequency where-  pure  = return-  Frequency fname fs <*> Frequency yname ys =-    Frequency ("(" <> fname <> ") <*> (" <> yname <> ")")-              [ (p * q, f y) | (p, f) <- fs-                             , (q, y) <- ys ]--instance MonadPlus Frequency where-  mplus (Frequency xname xs) (Frequency yname ys) =-    let name = case (xs, ys) of-          ([], []) -> "[]"-          ([], _ ) -> yname-          (_,  []) -> xname-          _ -> "(" <> xname <> ") ++ (" <> yname <> ")"-    in Frequency name (xs ++ ys)-  mzero = Frequency "[]" []--instance Alternative Frequency where-  (<|>) = mplus-  empty = mzero--instance Hashable a => Hashable (Frequency a)--instance Binary a => Binary (Frequency a)---- | Uniform discrete frequency distribution.-uniformFreq :: Text -> [a] -> Frequency a-uniformFreq name = Frequency name . map (\x -> (1, x))---- | Takes a name and a list of frequencies and items--- into the frequency distribution.-toFreq :: Text -> [(Int, a)] -> Frequency a-toFreq = Frequency---- | Scale frequecy distribution, multiplying it--- by a positive integer constant.-scaleFreq :: Show a => Int -> Frequency a -> Frequency a-scaleFreq n (Frequency name xs) =-  assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) $-  Frequency name (map (first (* n)) xs)---- | Change the description of the frequency.-renameFreq :: Text -> Frequency a -> Frequency a-renameFreq newName fr = fr {nameFrequency = newName}---- | Set frequency of an element.-setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a-setFreq (Frequency name xs) x n =-  let f (_, y) | y == x = (n, x)-      f my = my-  in Frequency name $ map f xs---- | Test if the frequency distribution is empty.-nullFreq :: Frequency a -> Bool-nullFreq (Frequency _ fs) = all (<= 0) $ map fst fs--maxFreq :: (Show a, Ord a) => Frequency a -> a-maxFreq fr@(Frequency _ xs) = case filter ((> 0 ) . fst) xs of-  [] -> assert `failure` fr-  ys -> maximum $ map snd ys--minFreq :: (Show a, Ord a) => Frequency a -> a-minFreq fr@(Frequency _ xs) = case filter ((> 0 ) . fst) xs of-  [] -> assert `failure` fr-  ys -> minimum $ map snd ys--meanFreq :: (Show a, Integral a) => Frequency a -> Rational-meanFreq fr@(Frequency _ xs) = case filter ((> 0 ) . fst) xs of-  [] -> assert `failure` fr-  ys -> let sumP = sum $ map fst ys-            sumX = sum [ fromIntegral p * x | (p, x) <- ys ]-        in if sumX == 0 then 0 else fromIntegral sumX % fromIntegral sumP
− Game/LambdaHack/Common/HighScore.hs 
@@ -1,199 +0,0 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | High score table operations.-module Game.LambdaHack.Common.HighScore-  ( ScoreTable, empty, register, showScore, getRecord, highSlideshow-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Generics (Generic)-import qualified NLP.Miniutter.English as MU-import System.Time--import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind---- | 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-  , difficulty   :: !Int        -- ^ difficulty of the game-  , gplayerName  :: !Text       -- ^ name of the faction's gplayer-  , ourVictims   :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ allies lost-  , theirVictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ foes killed-  }-  deriving (Eq, Ord, Show, Generic)--instance Binary ClockTime where-  put (TOD cs cp) = do-    put cs-    put cp-  get = do-    cs <- get-    cp <- get-    return $! TOD cs cp--instance Binary ScoreRecord---- | Show a single high score, from the given ranking in the high score table.-showScore :: (Int, ScoreRecord) -> [Text]-showScore (pos, score) =-  let Status{stOutcome, stDepth} = status score-      died = case stOutcome of-        Killed   -> "perished on level" <+> tshow (abs stDepth)-        Defeated -> "was defeated"-        Camping  -> "camps somewhere"-        Conquer  -> "slew all opposition"-        Escape   -> "emerged victorious"-        Restart  -> "resigned prematurely"-      curDate = T.pack $ calendarTimeToString . toUTCTime . date $ score-      turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn-      tpos = T.justifyRight 3 ' ' $ tshow pos-      tscore = T.justifyRight 6 ' ' $ tshow $ points score-      victims = let nkilled = sum $ EM.elems $ theirVictims score-                    nlost = sum $ EM.elems $ ourVictims score-                in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost-      diff = difficulty score-      diffText | diff == difficultyDefault = ""-               | otherwise = "difficulty" <+> tshow diff <> ", "-      tturns = makePhrase $ [MU.CarWs turns "turn"]-  in [ tpos <> "." <+> tscore <+> "The" <+> gplayerName score <+> "team"-       <+> died <> "," <+> victims <> ","-     , "            "-       <> diffText <> "after" <+> tturns <+> "on" <+> curDate <> "."-     ]--getRecord :: Int -> ScoreTable -> ScoreRecord-getRecord pos (ScoreTable table) =-  fromMaybe (assert `failure` (pos, table))-  $ listToMaybe $ drop (pred pos) table---- | The list of scores, in decreasing order.-newtype ScoreTable = ScoreTable [ScoreRecord]-  deriving (Eq, Binary)--instance Show ScoreTable where-  show _ = "a score table"---- | Empty score table-empty :: ScoreTable-empty = ScoreTable []---- | Insert a new score into the table, Return new table and the ranking.--- Make sure the table doesn't grow too large.-insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)-insertPos s (ScoreTable table) =-  let (prefix, suffix) = span (> s) table-      pos = length prefix + 1-  in (ScoreTable $ prefix ++ [s] ++ take (100 - pos) suffix, pos)---- | Register a new score in a score table.-register :: ScoreTable  -- ^ old table-         -> Int         -- ^ the total value of faction items-         -> Time        -- ^ game time spent-         -> Status      -- ^ reason of the game interruption-         -> ClockTime   -- ^ current date-         -> Int         -- ^ difficulty level-         -> Text        -- ^ name of the faction's gplayer-         -> EM.EnumMap (Kind.Id ItemKind) Int  -- ^ allies lost-         -> EM.EnumMap (Kind.Id ItemKind) Int  -- ^ foes killed-         -> Bool        -- ^ whether the faction fights against spawners-         -> (Bool, (ScoreTable, Int))-register table total time status@Status{stOutcome} date difficulty gplayerName-         ourVictims theirVictims fightsSpawners =-  let pBase =-        if fightsSpawners-        -- Heroes rejoice in loot and mourn their victims.-        then fromIntegral total-        -- Spawners or skirmishers get no bonus from loot and no malus-        -- from loses, but try to kill opponents fast and blodily,-        -- or at least hold up for long and incur heavy losses.-        else let turnsSpent = timeFitUp time timeTurn-                 speedup = max 0 $ 1000000 - 100 * turnsSpent-                 survival = 100 * turnsSpent-             in if stOutcome `elem` [Conquer, Escape]-                -- Up to 1000 points for quick victory, so up to 10000 turns.-                then sqrt $ fromIntegral speedup-                -- Up to 1000 points for surviving long, so up to 10000 turns.-                else min 1000-                     $ sqrt $ fromIntegral survival-      pBonus =-        if fightsSpawners-        then max 0 (1000 - 100 * sum (EM.elems ourVictims))-        else 1000 + 100 * sum (EM.elems theirVictims)-      pSum :: Double-      pSum = if stOutcome `elem` [Conquer, Escape]-             then pBase + fromIntegral pBonus-             else pBase-      points = (ceiling :: Double -> Int)-               $ pSum * 1.5 ^^ (- (difficultyCoeff difficulty))-      negTime = absoluteTimeNegate time-      score = ScoreRecord{..}-  in (points > 0, insertPos score table)---- | Show a screenful of the high scores table.--- Parameter height is the number of (3-line) scores to be shown.-tshowable :: ScoreTable -> Int -> Int -> [Text]-tshowable (ScoreTable table) start height =-  let zipped    = zip [1..] table-      screenful = take height . drop (start - 1) $ zipped-  in (intercalate ["\n"] $ map showScore screenful) ++ [moreMsg]---- | Produce a couple of renderings of the high scores table.-showCloseScores :: Int -> ScoreTable -> Int -> [[Text]]-showCloseScores pos h height =-  if pos <= height-  then [tshowable h 1 height]-  else [tshowable h 1 height,-        tshowable h (max (height + 1) (pos - height `div` 2)) height]---- | Generate a slideshow with the current and previous scores.-highSlideshow :: ScoreTable -- ^ current score table-              -> Int        -- ^ position of the current score in the table-              -> Slideshow-highSlideshow table pos =-  let (_, nlines) = normalLevelBound  -- TODO: query terminal size instead-      height = nlines `div` 3-      posStatus = status $ getRecord pos table-      (subject, person, msgUnless) =-        case stOutcome posStatus of-          Killed | stDepth posStatus <= 1 ->-            ("your short-lived struggle", MU.Sg3rd, "(no bonus)")-          Killed ->-            ("your heroic deeds", MU.PlEtc, "(no bonus)")-          Defeated ->-            ("your futile efforts", MU.PlEtc, "(no bonus)")-          Camping ->-            -- TODO: this is only according to the limited player knowledge;-            -- the final score can be different; say this somewhere-            ("your valiant exploits", MU.PlEtc, "")-          Conquer ->-            ("your ruthless victory", MU.Sg3rd,-             if pos <= height-             then "among the greatest heroes"-             else "(bonus included)")-          Escape ->-            ("your dashing coup", MU.Sg3rd,-             if pos <= height-             then "among the greatest heroes"-             else "(bonus included)")-          Restart ->-            ("your abortive attempt", MU.Sg3rd, "(no bonus)")-      msg = makeSentence-        [ MU.SubjectVerb person MU.Yes subject "award you"-        , MU.Ordinal pos, "place"-        , msgUnless ]-  in toSlideshow False $ map ([msg, "\n"] ++) $ showCloseScores pos table height
− Game/LambdaHack/Common/Item.hs 
@@ -1,123 +0,0 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}--- | Weapons, treasure and all the other items in the game.--- No operation in this module involves the state or any of our custom monads.-module Game.LambdaHack.Common.Item-  ( -- * The @Item@ type-    ItemId, Item(..), seedToAspectsEffects-    -- * Item discovery types-  , ItemKindIx, Discovery, ItemSeed, ItemAspectEffect(..), DiscoAE-  , ItemFull(..), ItemDisco(..), itemNoDisco, itemNoAE-    -- * Inventory management types-  , ItemBag, ItemDict, ItemKnown-  ) where--import qualified Control.Monad.State as St-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.Hashable (Hashable)-import qualified Data.Ix as Ix-import Data.Text (Text)-import GHC.Generics (Generic)-import System.Random (mkStdGen)--import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Flavour-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Content.ItemKind---- | A unique identifier of an item in the dungeon.-newtype ItemId = ItemId Int-  deriving (Show, Eq, Ord, Enum, Binary)---- | An index of the kind id of an item. Clients have partial knowledge--- how these idexes map to kind ids. They gain knowledge by identifying items.-newtype ItemKindIx = ItemKindIx Int-  deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary)---- | The map of item kind indexes to item kind ids.--- The full map, as known by the server, is a bijection.-type Discovery = EM.EnumMap ItemKindIx (Kind.Id ItemKind)---- | A seed for rolling aspects and effects of an item--- Clients have partial knowledge of how item ids map to the seeds.--- They gain knowledge by identifying items.-newtype ItemSeed = ItemSeed Int-  deriving (Show, Eq, Ord, Enum, Hashable, Binary)--data ItemAspectEffect = ItemAspectEffect-  { jaspects :: ![Aspect Int]  -- ^ the aspects of the item-  , jeffects :: ![Effect Int]  -- ^ the effects when activated-  }-  deriving (Show, Eq, Generic)--instance Binary ItemAspectEffect--instance Hashable ItemAspectEffect---- | The map of item ids to item aspects and effects.--- The full map is known by the server.-type DiscoAE = EM.EnumMap ItemId ItemAspectEffect--data ItemDisco = ItemDisco-  { itemKindId :: Kind.Id ItemKind-  , itemKind   :: ItemKind-  , itemAE     :: Maybe ItemAspectEffect-  }-  deriving Show--data ItemFull = ItemFull-  { itemBase  :: !Item-  , itemK     :: !Int-  , itemDisco :: !(Maybe ItemDisco)-  }-  deriving Show--itemNoDisco :: (Item, Int) -> ItemFull-itemNoDisco (itemBase, itemK) =-  ItemFull {itemBase, itemK, itemDisco=Nothing}--itemNoAE :: ItemFull -> ItemFull-itemNoAE itemFull@ItemFull{..} =-  let f idisco = idisco {itemAE = Nothing}-      newDisco = fmap f itemDisco-  in itemFull {itemDisco = newDisco}---- | Game items in actor possesion or strewn around the dungeon.--- The fields @jsymbol@, @jname@ and @jflavour@ make it possible to refer to--- and draw an unidentified item. Full information about item is available--- through the @jkindIx@ index as soon as the item is identified.-data Item = Item-  { jkindIx  :: !ItemKindIx    -- ^ index pointing to the kind of the item-  , jlid     :: !LevelId       -- ^ the level on which item was created-  , jsymbol  :: !Char          -- ^ individual map symbol-  , jname    :: !Text          -- ^ individual generic name-  , jflavour :: !Flavour       -- ^ individual flavour-  , jfeature :: ![Feature]     -- ^ public properties-  , jweight  :: !Int           -- ^ weight in grams, obvious enough-  }-  deriving (Show, Eq, Generic)--instance Hashable Item--instance Binary Item--seedToAspectsEffects :: ItemSeed -> ItemKind -> AbsDepth -> AbsDepth-                     -> ItemAspectEffect-seedToAspectsEffects (ItemSeed itemSeed) kind ldepth totalDepth =-  let castD = castDice ldepth totalDepth-      rollAE = do-        aspects <- mapM (flip aspectTrav castD) (iaspects kind)-        effects <- mapM (flip effectTrav castD) (ieffects kind)-        return (aspects, effects)-      (jaspects, jeffects) = St.evalState rollAE (mkStdGen itemSeed)-  in ItemAspectEffect{..}--type ItemBag = EM.EnumMap ItemId Int---- | All items in the dungeon (including in actor inventories),--- indexed by item identifier.-type ItemDict = EM.EnumMap ItemId Item--type ItemKnown = (Item, ItemAspectEffect)
− Game/LambdaHack/Common/ItemDescription.hs 
@@ -1,118 +0,0 @@--- | Descripitons of items.-module Game.LambdaHack.Common.ItemDescription-  ( partItemN, partItem, partItemWs, partItemAW, partItemWownW-  , itemDesc, textAllAE, viewItem-  ) where--import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.EffectDescription-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Content.ItemKind---- | The part of speech describing the item parameterized by the number--- of effects/aspects to show..-partItemN :: Bool -> Int -> CStore -> ItemFull -> (MU.Part, MU.Part)-partItemN fullInfo n cstore itemFull =-  let genericName = jname $ itemBase itemFull-  in case itemDisco itemFull of-    Nothing ->-      let flav = flavourToName $ jflavour $ itemBase itemFull-      in (MU.Text $ flav <+> genericName, "")-    Just _ ->-      let effTs = filter (not . T.null) $ textAllAE fullInfo cstore itemFull-          ts = take n effTs ++ if length effTs > n then ["(...)"] else []-      in (MU.Text genericName, MU.Phrase $ map MU.Text ts)---- | The part of speech describing the item.-partItem :: CStore -> ItemFull -> (MU.Part, MU.Part)-partItem = partItemN False 4--textAllAE :: Bool -> CStore -> ItemFull -> [Text]-textAllAE fullInfo cstore ItemFull{itemBase, itemDisco} =-  let features | fullInfo = map featureToSuff $ sort $ jfeature itemBase-               | otherwise = []-  in case itemDisco of-    Nothing -> features-    Just ItemDisco{itemKind, itemAE} ->-      let periodicAspect :: Effect.Aspect a -> Bool-          periodicAspect (Effect.Periodic _) = True-          periodicAspect _ = False-          hurtEffect :: Effect.Effect a -> Bool-          hurtEffect (Effect.Hurt _) = True-          hurtEffect _ = False-          active = cstore `elem` [CEqp, COrgan]-                   || cstore == CGround && isJust (strengthEqpSlot itemBase)-          splitAE :: Ord a-                  => [Effect.Aspect a] -> (Effect.Aspect a -> Text)-                  -> [Effect.Effect a] -> (Effect.Effect a -> Text) -> [Text]-          splitAE aspects ppA effects ppE =-            let (periodicAs, restAs) = partition periodicAspect $ sort aspects-                (hurtEs, restEs) = partition hurtEffect $ sort effects-            in map ppA periodicAs ++ map ppE hurtEs-               ++ if active-                  then map ppA restAs ++ map ppE restEs-                  else map ppE restEs ++ map ppA restAs-          aets = case itemAE of-            Just ItemAspectEffect{jaspects, jeffects} ->-              splitAE jaspects aspectToSuffix-                      jeffects effectToSuffix-            Nothing ->-              splitAE (iaspects itemKind) kindAspectToSuffix-                      (ieffects itemKind) kindEffectToSuffix-      in aets ++ features--partItemWs :: Int -> CStore -> ItemFull -> MU.Part-partItemWs count cstore itemFull =-  let (name, stats) = partItem cstore itemFull-  in MU.Phrase [MU.CarWs count name, stats]--partItemAW :: CStore -> ItemFull -> MU.Part-partItemAW cstore itemFull =-  let (name, stats) = partItem cstore itemFull-  in MU.AW $ MU.Phrase [name, stats]--partItemWownW :: MU.Part -> CStore -> ItemFull -> MU.Part-partItemWownW partA cstore itemFull =-  let (name, stats) = partItem cstore itemFull-  in MU.WownW partA $ MU.Phrase [name, stats]--itemDesc :: CStore -> ItemFull -> Overlay-itemDesc cstore itemFull =-  let (name, stats) = partItemN True 99 cstore itemFull-      nstats = makePhrase [name, stats MU.:> ":"]-      desc = case itemDisco itemFull of-        Nothing -> "This item is as unremarkable as can be."-        Just ItemDisco{itemKind} -> idesc itemKind-      weight = jweight (itemBase itemFull)-      (scaledWeight, unitWeight) =-        if weight > 1000-        then (tshow $ fromIntegral weight / (1000 :: Double), "kg")-        else (tshow weight, "g")-      ln = abs $ fromEnum $ jlid (itemBase itemFull)-      colorSymbol = uncurry (flip Color.AttrChar) (viewItem $ itemBase itemFull)-      f c = Color.AttrChar Color.defAttr c-      lxsize = fst normalLevelBound + 1  -- TODO-      blurb =-        "D"  -- dummy-        <+> nstats-        <+> desc-        <+> makeSentence ["Weighs", MU.Text scaledWeight <> unitWeight]-        <+> makeSentence ["Found on level", MU.Text $ tshow ln]-      splitBlurb = splitText lxsize blurb-      attrBlurb = map (map f . T.unpack) splitBlurb-  in encodeOverlay $ (colorSymbol : tail (head attrBlurb)) : tail attrBlurb--viewItem :: Item -> (Char, Color.Attr)-viewItem item = ( jsymbol item-                , Color.defAttr {Color.fg = flavourToColor $ jflavour item} )
− Game/LambdaHack/Common/ItemStrongest.hs 
@@ -1,276 +0,0 @@--- | Determining the strongest item wrt some property.--- No operation in this module involves the state or any of our custom monads.-module Game.LambdaHack.Common.ItemStrongest-  ( -- * Strongest items-    strengthOnSmash, strengthToThrow, strengthEqpSlot, strengthFromEqpSlot-  , strongestSlotNoFilter, strongestSlot, sumSlotNoFilter, sumSkills-    -- * Assorted-  , totalRange, computeTrajectory, itemTrajectory-  , unknownPrecious, permittedRanged, unknownMelee-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import qualified Control.Monad.State as St-import qualified Data.EnumMap.Strict as EM-import Data.List-import Data.Maybe-import qualified Data.Ord as Ord-import Data.Text (Text)--import qualified Game.LambdaHack.Common.Ability as Ability-import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind--dice999 :: Dice.Dice -> Int-dice999 d = fromMaybe 999 $ Dice.reduceDice d--strengthAspect :: (Aspect Int -> [b]) -> ItemFull -> [b]-strengthAspect f itemFull =-  case itemDisco itemFull of-    Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects}} ->-      concatMap f jaspects-    Just ItemDisco{itemKind=ItemKind{iaspects}} ->-      -- Approximation. For some effects lower values are better,-      -- so we can't put 999 here (and for summation, this is wrong).-      let trav x = St.evalState (aspectTrav x (return . round . Dice.meanDice))-                                ()-      in concatMap f $ map trav iaspects-    Nothing -> []--strengthAspectMaybe :: Show b => (Aspect Int -> [b]) -> ItemFull -> Maybe b-strengthAspectMaybe f itemFull =-  case strengthAspect f itemFull of-    [] -> Nothing-    [x] -> Just x-    xs -> assert `failure` (xs, itemFull)--strengthEffect999 :: (Effect Int -> [b]) -> ItemFull -> [b]-strengthEffect999 f itemFull =-  case itemDisco itemFull of-    Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-      concatMap f jeffects-    Just ItemDisco{itemKind=ItemKind{ieffects}} ->-      -- Default for unknown power is 999 to encourage experimenting.-      let trav x = St.evalState (effectTrav x (return . dice999)) ()-      in concatMap f $ map trav ieffects-    Nothing -> []--strengthFeature :: (Feature -> [b]) -> Item -> [b]-strengthFeature f item = concatMap f (jfeature item)--strengthMelee :: ItemFull -> Maybe Int-strengthMelee itemFull =-  let durable = Durable `elem` jfeature (itemBase itemFull)-      p (Hurt d) = [floor (Dice.meanDice d)]-      p (Burn k) = [k]-      p _ = []-      hasNoEffects = case itemDisco itemFull of-        Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-          null jeffects-        Just ItemDisco{itemKind=ItemKind{ieffects}} ->-          null ieffects-        Nothing -> True-  in if hasNoEffects-     then Nothing-     else Just $ sum (strengthEffect999 p itemFull)-                 + if durable then 100 else 0---- Called only by the server, so 999 is OK.-strengthOnSmash :: ItemFull -> [Effect Int]-strengthOnSmash =-  let p (OnSmash eff) = [eff]-      p _ = []-  in strengthEffect999 p--strengthPeriodic :: ItemFull -> Maybe Int-strengthPeriodic =-  let p (Periodic k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddMaxHP :: ItemFull -> Maybe Int-strengthAddMaxHP =-  let p (AddMaxHP k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddMaxCalm :: ItemFull -> Maybe Int-strengthAddMaxCalm =-  let p (AddMaxCalm k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddSpeed :: ItemFull -> Maybe Int-strengthAddSpeed =-  let p (AddSpeed k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddSkills :: ItemFull -> Maybe Ability.Skills-strengthAddSkills =-  let p (AddSkills a) = [a]-      p _ = []-  in strengthAspectMaybe p--strengthAddHurtMelee :: ItemFull -> Maybe Int-strengthAddHurtMelee =-  let p (AddHurtMelee k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddHurtRanged :: ItemFull -> Maybe Int-strengthAddHurtRanged =-  let p (AddHurtRanged k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddArmorMelee :: ItemFull -> Maybe Int-strengthAddArmorMelee =-  let p (AddArmorMelee k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddArmorRanged :: ItemFull -> Maybe Int-strengthAddArmorRanged =-  let p (AddArmorRanged k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddSight :: ItemFull -> Maybe Int-strengthAddSight =-  let p (AddSight k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddSmell :: ItemFull -> Maybe Int-strengthAddSmell =-  let p (AddSmell k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthAddLight :: ItemFull -> Maybe Int-strengthAddLight =-  let p (AddLight k) = [k]-      p _ = []-  in strengthAspectMaybe p--strengthEqpSlot :: Item -> Maybe (EqpSlot, Text)-strengthEqpSlot item =-  let p (EqpSlot eqpSlot t) = [(eqpSlot, t)]-      p _ = []-  in case strengthFeature p item of-    [] -> Nothing-    [x] -> Just x-    xs -> assert `failure` (xs, item)--strengthToThrow :: Item -> ThrowMod-strengthToThrow item =-  let p (ToThrow tmod) = [tmod]-      p _ = []-  in case strengthFeature p item of-    [] -> ThrowMod 100 100-    [x] -> x-    xs -> assert `failure` (xs, item)--computeTrajectory :: Int -> Int -> Int -> [Point] -> ([Vector], (Speed, Int))-computeTrajectory weight throwVelocity throwLinger path =-  let speed = speedFromWeight weight throwVelocity-      trange = rangeFromSpeedAndLinger speed throwLinger-      btrajectory = take trange $ pathToTrajectory path-  in (btrajectory, (speed, trange))--itemTrajectory :: Item -> [Point] -> ([Vector], (Speed, Int))-itemTrajectory item path =-  let ThrowMod{..} = strengthToThrow item-  in computeTrajectory (jweight item) throwVelocity throwLinger path--totalRange :: Item -> Int-totalRange item = snd $ snd $ itemTrajectory item []---- TODO: when all below are aspects, define with--- (EqpSlotAddMaxHP, AddMaxHP k) -> [k]-strengthFromEqpSlot :: EqpSlot -> ItemFull -> Maybe Int-strengthFromEqpSlot eqpSlot =-  case eqpSlot of-    EqpSlotPeriodic -> strengthPeriodic  -- a very crude approximation-    EqpSlotAddMaxHP -> strengthAddMaxHP-    EqpSlotAddMaxCalm -> strengthAddMaxCalm-    EqpSlotAddSpeed -> strengthAddSpeed-    EqpSlotAddSkills -> \itemFull -> sum . EM.elems <$> strengthAddSkills itemFull-    EqpSlotAddHurtMelee -> strengthAddHurtMelee-    EqpSlotAddHurtRanged -> strengthAddHurtRanged-    EqpSlotAddArmorMelee -> strengthAddArmorMelee-    EqpSlotAddArmorRanged -> strengthAddArmorRanged-    EqpSlotAddSight -> strengthAddSight-    EqpSlotAddSmell -> strengthAddSmell-    EqpSlotAddLight -> strengthAddLight-    EqpSlotWeapon -> strengthMelee--strongestSlotNoFilter :: EqpSlot -> [(ItemId, ItemFull)]-                      -> [(Int, (ItemId, ItemFull))]-strongestSlotNoFilter eqpSlot is =-  let f = strengthFromEqpSlot eqpSlot-      g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> (f itemFull)-  in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is--strongestSlot :: EqpSlot -> [(ItemId, ItemFull)]-              -> [(Int, (ItemId, ItemFull))]-strongestSlot eqpSlot is =-  let f (_, itemFull) = case strengthEqpSlot $ itemBase itemFull of-        Just (eqpSlot2, _) | eqpSlot2 == eqpSlot -> True-        _ -> False-      slotIs = filter f is-  in strongestSlotNoFilter eqpSlot slotIs--sumSlotNoFilter :: EqpSlot -> [ItemFull] -> Int-sumSlotNoFilter eqpSlot is = assert (eqpSlot /= EqpSlotWeapon) $  -- no 999-  let f = strengthFromEqpSlot eqpSlot-      g itemFull = (* itemK itemFull) <$> f itemFull-  in sum $ mapMaybe g is--sumSkills :: [ItemFull] -> Ability.Skills-sumSkills is =-  let g itemFull = (Ability.scaleSkills (itemK itemFull))-                   <$> strengthAddSkills itemFull-  in foldr Ability.addSkills Ability.zeroSkills $ mapMaybe g is--unknownPrecious :: ItemFull -> Bool-unknownPrecious itemFull =-  Durable `notElem` jfeature (itemBase itemFull)  -- if durable, no risk-  && case itemDisco itemFull of-    Just ItemDisco{itemAE=Just _} -> False-    _ -> Precious `elem` jfeature (itemBase itemFull)--permittedRanged :: ItemFull -> Maybe Int -> Bool-permittedRanged itemFull _ =-  let hasEffects = case itemDisco itemFull of-        Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects=[]}} -> False-        Just ItemDisco{itemAE=Nothing, itemKind=ItemKind{ieffects=[]}} -> False-        _ -> True-  in hasEffects-     && not (unknownPrecious itemFull)-     && case strengthEqpSlot (itemBase itemFull) of-          Just (EqpSlotAddLight, _) -> True-          Just _ -> False-          Nothing -> True--unknownAspect :: (Aspect Dice.Dice -> [Dice.Dice]) -> ItemFull -> Bool-unknownAspect f itemFull =-  case itemDisco itemFull of-    Just ItemDisco{itemAE=Nothing, itemKind=ItemKind{iaspects}} ->-      let unknown x = Dice.minDice x /= Dice.maxDice x-      in or $ concatMap (map unknown . f) iaspects-    _ -> False--unknownMelee :: [ItemFull] -> Bool-unknownMelee =-  let p (AddHurtMelee k) = [k]-      p _ = []-      f itemFull b = b || unknownAspect p itemFull-  in foldr f False
− Game/LambdaHack/Common/Kind.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-}--- | General content types and operations.-module Game.LambdaHack.Common.Kind-  ( Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset-  , Tab, createTab, accessTab-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.Array.Unboxed as A-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.Ix as Ix-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Content.CaveKind-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.PlaceKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind---- | Content identifiers for the content type @c@.-newtype Id c = Id Word8-  deriving (Show, Eq, Ord, Ix.Ix, Enum, Bounded, Binary)---- | Type family for auxiliary data structures for speeding up--- content operations.-data family Speedup a--data instance Speedup TileKind = TileSpeedup-  { isClearTab :: !Tab-  , isLitTab   :: !Tab-  , isWalkableTab :: !Tab-  , isPassableTab :: !Tab-  , isDoorTab :: !Tab-  , isSuspectTab :: !Tab-  , isChangeableTab :: !Tab-  }--newtype Tab = Tab (A.UArray (Id TileKind) Bool)--createTab :: Ops TileKind -> (TileKind -> Bool) -> Tab-createTab Ops{ofoldrWithKey, obounds} p =-  let f _ k acc = p k : acc-      clearAssocs = ofoldrWithKey f []-  in Tab $ A.listArray obounds clearAssocs--accessTab :: Tab -> Id TileKind -> Bool-{-# INLINE accessTab #-}-accessTab (Tab tab) ki = tab A.! ki---- | Content operations for the content of type @a@.-data Ops a = Ops-  { okind         :: Id a -> a      -- ^ the content element at given id-  , ouniqGroup    :: Text -> Id a   -- ^ the id of the unique member of-                                    --   a singleton content group-  , opick         :: Text -> (a -> Bool) -> Rnd (Maybe (Id a))-                                    -- ^ pick a random id belonging to a group-                                    --   and satisfying a predicate-  , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b-                                    -- ^ fold over all content elements of @a@-  , ofoldrGroup   :: forall b. Text -> (Int -> Id a -> a -> b -> b) -> b -> b-                                    -- ^ fold over the given group only-  , obounds       :: !(Id a, Id a)  -- ^ bounds of identifiers of content @a@-  , ospeedup      :: !(Maybe (Speedup a))  -- ^ auxiliary speedup components-  }---- | Create content operations for type @a@ from definition of content--- of type @a@.-createOps :: forall a. Show a => ContentDef a -> Ops a-createOps ContentDef{getName, getFreq, content, validate} =-  assert (length content <= fromEnum (maxBound :: Id a)) $-  let kindMap :: EM.EnumMap (Id a) a-      !kindMap = EM.fromDistinctAscList $ zip [Id 0..] content-      kindFreq :: M.Map Text [(Int, (Id a, a))]-      kindFreq =-        let tuples = [ (cgroup, (n, (i, k)))-                     | (i, k) <- EM.assocs kindMap-                     , (cgroup, n) <- getFreq k, n > 0 ]-            f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m-        in foldl' f M.empty tuples-      okind i = fromMaybe (assert `failure` "no kind" `twith` (i, kindMap))-                $ EM.lookup i kindMap-      correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a)-      offenders = validate content-  in assert (allB correct content) $-     assert (null offenders `blame` "content not valid" `twith` offenders)-     -- By this point 'content' can be GCd.-     Ops-       { okind-       , ouniqGroup = \cgroup ->-           let freq = fromMaybe (assert `failure` "no unique group"-                                        `twith` (cgroup, kindFreq))-                      $ M.lookup cgroup kindFreq-           in case freq of-             [(n, (i, _))] | n > 0 -> i-             l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq)-       , opick = \cgroup p ->-           case M.lookup cgroup kindFreq of-             Just freqRaw ->-               let freq = toFreq ("opick ('" <> cgroup <> "')") freqRaw-               in if nullFreq freq-                  then return Nothing-                  else fmap Just $ frequency $ do-                    (i, k) <- freq-                    breturn (p k) i-                    {- with MonadComprehensions:-                    frequency [ i | (i, k) <- kindFreq M.! cgroup, p k ]-                    -}-             _ -> return Nothing-       , ofoldrWithKey = \f z -> foldr (\(i, a) -> f i a) z-                                 $ EM.assocs kindMap-       , ofoldrGroup = \cgroup f z ->-           case M.lookup cgroup kindFreq of-             Just freq -> foldr (\(p, (i, a)) -> f p i a) z freq-             _ -> z-       , obounds = ( fst $ EM.findMin kindMap-                   , fst $ EM.findMax kindMap )-       , ospeedup = Nothing  -- define elsewhere-       }---- | Operations for all content types, gathered together.-data COps = COps-  { cocave    :: !(Ops CaveKind)     -- server only-  , cofaction :: !(Ops FactionKind)-  , coitem    :: !(Ops ItemKind)-  , comode    :: !(Ops ModeKind)     -- server only-  , coplace   :: !(Ops PlaceKind)    -- server only, so far-  , corule    :: !(Ops RuleKind)-  , cotile    :: !(Ops TileKind)-  }---- | The standard ruleset used for level operations.-stdRuleset :: Ops RuleKind -> RuleKind-stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard"--instance Show COps where-  show _ = "game content"--instance Eq COps where-  (==) _ _ = True
− Game/LambdaHack/Common/LQueue.hs 
@@ -1,59 +0,0 @@--- | Queues implemented with two stacks to ensure fast writes.-module Game.LambdaHack.Common.LQueue-  ( LQueue-  , newLQueue, nullLQueue, lengthLQueue, tryReadLQueue, writeLQueue-  , trimLQueue, dropStartLQueue, lastLQueue, toListLQueue-  ) where--import Data.Maybe---- | Queues implemented with two stacks.-type LQueue a = ([a], [a])  -- (read_end, write_end)---- | Create a new empty mutable queue.-newLQueue :: LQueue a-newLQueue = ([], [])---- | Check if the queue is empty.-nullLQueue :: LQueue a -> Bool-nullLQueue (rs, ws) = null rs && null ws---- | The length of the queue.-lengthLQueue :: LQueue a -> Int-lengthLQueue (rs, ws) = length rs + length ws---- | Try reading a queue. Return @Nothing@ if empty.-tryReadLQueue :: LQueue a -> Maybe (a, LQueue a)-tryReadLQueue (r : rs, ws) = Just (r, (rs, ws))-tryReadLQueue ([], []) = Nothing-tryReadLQueue ([], ws) = tryReadLQueue (reverse ws, [])---- | Write to the queue. Faster than reading.-writeLQueue :: LQueue a -> a -> LQueue a-writeLQueue (rs, ws) w = (rs, w : ws)---- | Remove all but the last written non-@Nothing@ element of the queue.-trimLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)-trimLQueue (rs, ws) =-  let trim (_, w:_) = ([w], [])-      trim ([], []) = ([], [])-      trim (rsj, []) = ([last rsj], [])-  in trim (filter isJust rs, filter isJust ws)---- | Remove frames up to and including the first segment of @Nothing@ frames.--- | If the resulting queue is empty, apply trimLQueue instead.-dropStartLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)-dropStartLQueue (rs, ws) =-  let dq = (dropWhile isNothing $ dropWhile isJust $ rs ++ reverse ws, [])-  in if nullLQueue dq then trimLQueue (rs, ws) else dq---- | Dump all but the last written non-@Nothing@ element of the queue, if any.-lastLQueue :: LQueue (Maybe a) -> Maybe a-lastLQueue (rs, ws) =-  let lst (_, w:_) = Just w-      lst ([], []) = Nothing-      lst (rsj, []) = Just $ last rsj-  in lst (catMaybes rs, catMaybes ws)--toListLQueue :: LQueue a -> [a]-toListLQueue (rs, ws) = rs ++ reverse ws
− Game/LambdaHack/Common/Level.hs 
@@ -1,253 +0,0 @@--- | Inhabited dungeon levels and the operations to query and change them--- as the game progresses.-module Game.LambdaHack.Common.Level-  ( -- * Dungeon-    LevelId, AbsDepth, Dungeon, ascendInBranch-    -- * The @Level@ type and its components-  , Level(..), ActorPrio, ItemFloor, TileMap, SmellMap-    -- * Level query-  , at, atI, checkAccess, checkDoorAccess-  , accessible, accessibleUnknown, accessibleDir-  , knownLsecret, isSecretPos, hideTile-  , findPos, findPosTry, mapLevelActors_, mapDungeonActors_- ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.Bits as Bits-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Text (Text)--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Tile-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind---- | The complete dungeon is a map from level names to levels.-type Dungeon = EM.EnumMap LevelId Level---- | Levels in the current branch, @k@ levels shallower than the current.-ascendInBranch :: Dungeon -> Int -> LevelId -> [LevelId]-ascendInBranch dungeon k lid =-  -- Currently there is just one branch, so the computation is simple.-  let (minD, maxD) =-        case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of-          (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` "null dungeon" `twith` dungeon-      ln = max minD $ min maxD $ toEnum $ fromEnum lid + k-  in case EM.lookup ln dungeon of-    Just _ | ln /= lid -> [ln]-    _ | ln == lid -> []-    _ -> ascendInBranch dungeon k ln  -- jump over gaps---- | Actor time priority queue.-type ActorPrio = EM.EnumMap Time [ActorId]---- | Items located on map tiles.-type ItemFloor = EM.EnumMap Point ItemBag---- | Tile kinds on the map.-type TileMap = PointArray.Array (Kind.Id TileKind)---- | Current smell on map tiles.-type SmellMap = EM.EnumMap Point SmellTime---- | A view on single, inhabited dungeon level. "Remembered" fields--- carry a subset of the info in the client copies of levels.-data Level = Level-  { ldepth     :: !AbsDepth   -- ^ absolute depth of the level-  , lprio      :: !ActorPrio  -- ^ remembered actor times on the level-  , lfloor     :: !ItemFloor  -- ^ remembered items lying on the floor-  , ltile      :: !TileMap    -- ^ remembered level map-  , lxsize     :: !X          -- ^ width of the level-  , lysize     :: !Y          -- ^ height of the level-  , lsmell     :: !SmellMap   -- ^ remembered smells on the level-  , ldesc      :: !Text       -- ^ level description-  , lstair     :: !([Point], [Point])-                              -- ^ destinations of (up, down) stairs-  , lseen      :: !Int        -- ^ currently remembered clear tiles-  , lclear     :: !Int        -- ^ total number of initially clear tiles-  , ltime      :: !Time       -- ^ date of the last activity on the level-  , lactorFreq :: !Freqs      -- ^ frequency of spawned actors; [] for clients-  , litemNum   :: !Int        -- ^ number of initial items, 0 for clients-  , litemFreq  :: !Freqs      -- ^ frequency of initial items; [] for clients-  , lsecret    :: !Int        -- ^ secret tile seed-  , lhidden    :: !Int        -- ^ secret tile density-  , lescape    :: !Bool       -- ^ has an Effect.Escape tile-  }-  deriving (Show, Eq)--assertSparseItems :: ItemFloor -> ItemFloor-assertSparseItems m =-  assert (EM.null (EM.filter EM.null m)-          `blame` "null floors found" `twith` m) m---- | Query for tile kinds on the map.-at :: Level -> Point -> Kind.Id TileKind-at Level{ltile} p = ltile PointArray.! p---- | Query for items on the ground.-atI :: Level -> Point -> ItemBag-atI Level{lfloor} p = EM.findWithDefault EM.empty p lfloor--checkAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool)-checkAccess Kind.COps{corule} _ =-  case raccessible $ Kind.stdRuleset corule of-    Nothing -> Nothing-    Just ch -> Just $ \spos tpos -> ch spos tpos--checkDoorAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool)-checkDoorAccess Kind.COps{corule, cotile} lvl =-  case raccessibleDoor $ Kind.stdRuleset corule of-    Nothing -> Nothing-    Just chDoor ->-      Just $ \spos tpos ->-        let st = lvl `at` spos-            tt = lvl `at` tpos-        in not (Tile.isDoor cotile st || Tile.isDoor cotile tt)-           || chDoor spos tpos---- | Check whether one position is accessible from another,--- using the formula from the standard ruleset.--- Precondition: the two positions are next to each other.-accessible :: Kind.COps -> Level -> Point -> Point -> Bool-accessible cops@Kind.COps{cotile} lvl =-  let checkWalkability =-        Just $ \_ tpos -> Tile.isWalkable cotile $ lvl `at` tpos-      conditions = catMaybes [ checkWalkability-                             , checkAccess cops lvl-                             , checkDoorAccess cops lvl ]-  in \spos tpos -> all (\f -> f spos tpos) conditions---- | Check whether one position is accessible from another,--- using the formula from the standard ruleset,--- but additionally treating unknown tiles as walkable.--- Precondition: the two positions are next to each other.-accessibleUnknown :: Kind.COps -> Level -> Point -> Point -> Bool-accessibleUnknown cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} lvl =-  let unknownId = ouniqGroup "unknown space"-      checkWalkability =-        Just $ \_ tpos -> let t = lvl `at` tpos-                          in Tile.isWalkable cotile t || t == unknownId-      conditions = catMaybes [ checkWalkability-                             , checkAccess cops lvl-                             , checkDoorAccess cops lvl ]-  in \spos tpos -> all (\f -> f spos tpos) conditions---- | Check whether actors can move from a position along a unit vector,--- using the formula from the standard ruleset.-accessibleDir :: Kind.COps -> Level -> Point -> Vector -> Bool-accessibleDir cops lvl spos dir = accessible cops lvl spos $ spos `shift` dir--knownLsecret :: Level -> Bool-knownLsecret lvl = lsecret lvl /= 0--isSecretPos :: Level -> Point -> Bool-isSecretPos lvl (Point x y) =-  (lsecret lvl `Bits.rotateR` x `Bits.xor` y + x) `mod` lhidden lvl == 0--hideTile :: Kind.Ops TileKind -> Level -> Point -> Kind.Id TileKind-hideTile cotile lvl p =-  let t = lvl `at` p-      ht = Tile.hideAs cotile t  -- TODO; tabulate with Speedup?-  in if isSecretPos lvl p then ht else t---- | Find a random position on the map satisfying a predicate.-findPos :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point-findPos ltile p =-  let (x, y) = PointArray.sizeA ltile-      search = do-        px <- randomR (0, x - 1)-        py <- randomR (0, y - 1)-        let pos = Point{..}-            tile = ltile PointArray.! pos-        if p pos tile-          then return $! pos-          else search-  in search---- | Try to find a random position on the map satisfying--- the conjunction of the list of predicates.--- If the permitted number of attempts is not enough,--- try again the same number of times without the first predicate,--- then without the first two, etc., until only one predicate remains,--- at which point try as many times, as needed.-findPosTry :: Int                                  -- ^ the number of tries-           -> TileMap                              -- ^ look up in this map-           -> (Point -> Kind.Id TileKind -> Bool)  -- ^ mandatory predicate-           -> [Point -> Kind.Id TileKind -> Bool]  -- ^ optional predicates-           -> Rnd Point-findPosTry _        ltile m []         = findPos ltile m-findPosTry numTries ltile m l@(_ : tl) = assert (numTries > 0) $-  let (x, y) = PointArray.sizeA ltile-      search 0 = findPosTry numTries ltile m tl-      search k = do-        px <- randomR (0, x - 1)-        py <- randomR (0, y - 1)-        let pos = Point{..}-            tile = ltile PointArray.! pos-        if m pos tile && all (\p -> p pos tile) l-          then return $! pos-          else search (k - 1)-  in search numTries--mapLevelActors_ :: Monad m => (ActorId -> m a) -> Level -> m ()-mapLevelActors_ f Level{lprio} = do-  let as = concat $ EM.elems lprio-  mapM_ f as--mapDungeonActors_ :: Monad m => (ActorId -> m a) -> Dungeon -> m ()-mapDungeonActors_ f dungeon = do-  let ls = EM.elems dungeon-  mapM_ (mapLevelActors_ f) ls--instance Binary Level where-  put Level{..} = do-    put ldepth-    put lprio-    put (assertSparseItems lfloor)-    put ltile-    put lxsize-    put lysize-    put lsmell-    put ldesc-    put lstair-    put lseen-    put lclear-    put ltime-    put lactorFreq-    put litemNum-    put litemFreq-    put lsecret-    put lhidden-    put lescape-  get = do-    ldepth <- get-    lprio <- get-    lfloor <- get-    ltile <- get-    lxsize <- get-    lysize <- get-    lsmell <- get-    ldesc <- get-    lstair <- get-    lseen <- get-    lclear <- get-    ltime <- get-    lactorFreq <- get-    litemNum <- get-    litemFreq <- get-    lsecret <- get-    lhidden <- get-    lescape <- get-    return $! Level{..}
− Game/LambdaHack/Common/Misc.hs 
@@ -1,147 +0,0 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Hacks that haven't found their home yet.-module Game.LambdaHack.Common.Misc-  ( -- * Game object identifiers-    FactionId, LevelId, AbsDepth(..), ActorId-    -- * Item containers-  , Container(..), CStore(..)-    -- * Assorted-  , normalLevelBound, divUp, Freqs, breturn-  , serverSaveName, nearby-  ) where--import Control.Monad-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Functor-import Data.Hashable-import qualified Data.HashMap.Strict as HM-import Data.Key-import Data.Text (Text)-import Data.Traversable (traverse)-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Point---- | What distance signifies that two actors are "nearby".-nearby :: Int-nearby = 10--serverSaveName :: String-serverSaveName = "server.sav"---- | Level bounds. TODO: query terminal size instead and scroll view.-normalLevelBound :: (Int, Int)-normalLevelBound = (79, 20)--infixl 7 `divUp`--- | Integer division, rounding up.-divUp :: Integral a => a -> a -> a-divUp n k = (n + k - 1) `div` k---- | For each group that the kind belongs to, denoted by a @Text@ name--- in the first component of a pair, the second component of a pair shows--- how common the kind is within the group.-type Freqs = [(Text, Int)]---- | @breturn b a = [a | b]@-breturn :: MonadPlus m => Bool -> a -> m a-breturn True a  = return a-breturn False _ = mzero---- | Item container type.-data Container =-    CFloor !LevelId !Point-  | CActor !ActorId !CStore-  | CTrunk !FactionId !LevelId !Point   -- ^ for bootstrapping actor bodies-  deriving (Show, Eq, Ord, Generic)--instance Binary Container--data CStore =-    CGround-  | COrgan-  | CEqp-  | CInv-  | CSha-  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)--instance Binary CStore--instance Hashable CStore---- | A unique identifier of a faction in a game.-newtype FactionId = FactionId Int-  deriving (Show, Eq, Ord, Enum, Binary)---- | Abstract level identifiers.-newtype LevelId = LevelId Int-  deriving (Show, Eq, Ord, Enum, Hashable, Binary)---- | Absolute depth in the dungeon. When used for the maximum depth--- of the whole dungeon, this can be different than dungeon size,--- e.g., when the dungeon is branched, and it can even be different--- than the length of the longest branch, if levels at some depths are missing.-newtype AbsDepth = AbsDepth Int-  deriving (Show, Eq, Ord, Hashable, Binary)---- | A unique identifier of an actor in the dungeon.-newtype ActorId = ActorId Int-  deriving (Show, Eq, Ord, Enum, Binary)---- Data.Binary--instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where-  {-# INLINEABLE put #-}-  put m = put (EM.size m) >> mapM_ put (EM.toAscList m)-  {-# INLINEABLE get #-}-  get = liftM EM.fromDistinctAscList get--instance (Enum k, Binary k) => Binary (ES.EnumSet k) where-  {-# INLINEABLE put #-}-  put m = put (ES.size m) >> mapM_ put (ES.toAscList m)-  {-# INLINEABLE get #-}-  get = liftM ES.fromDistinctAscList get--instance (Binary k, Binary v, Eq k, Hashable k) => Binary (HM.HashMap k v) where-  {-# INLINEABLE put #-}-  put ir = put $ HM.toList ir-  {-# INLINEABLE get #-}-  get = fmap HM.fromList get---- Data.Key--type instance Key (EM.EnumMap k) = k--instance Zip (EM.EnumMap k) where-  zipWith = EM.intersectionWith--instance Enum k => ZipWithKey (EM.EnumMap k) where-  zipWithKey = EM.intersectionWithKey--instance Enum k => Keyed (EM.EnumMap k) where-  mapWithKey = EM.mapWithKey--instance Enum k => FoldableWithKey (EM.EnumMap k) where-  foldrWithKey = EM.foldrWithKey--instance Enum k => TraversableWithKey (EM.EnumMap k) where-  traverseWithKey f = fmap EM.fromDistinctAscList-                      . traverse (\(k, v) -> (,) k <$> f k v) . EM.toAscList--instance Enum k => Indexable (EM.EnumMap k) where-  index = (EM.!)--instance Enum k => Lookup (EM.EnumMap k) where-  lookup = EM.lookup--instance Enum k => Adjustable (EM.EnumMap k) where-  adjust = EM.adjust---- Data.Hashable--instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where-  {-# INLINEABLE hashWithSalt #-}-  hashWithSalt s x = hashWithSalt s (EM.toAscList x)
− Game/LambdaHack/Common/MonadStateRead.hs 
@@ -1,41 +0,0 @@--- | Game action monads and basic building blocks for human and computer--- player actions. Has no access to the the main action type.-module Game.LambdaHack.Common.MonadStateRead-  ( MonadStateRead(..)-  , getLevel, nUI, posOfAid, fightsAgainstSpawners-  ) where--import qualified Data.EnumMap.Strict as EM--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind--class (Monad m, Functor m) => MonadStateRead m where-  getState  :: m State-  getsState :: (State -> a) -> m a--getLevel :: MonadStateRead m => LevelId -> m Level-getLevel lid = getsState $ (EM.! lid) . sdungeon--nUI :: MonadStateRead m => m Int-nUI = do-  factionD <- getsState sfactionD-  return $! length $ filter (playerUI . gplayer) $ EM.elems factionD--posOfAid :: MonadStateRead m => ActorId -> m (LevelId, Point)-posOfAid aid = do-  b <- getsState $ getActorBody aid-  return (blid b, bpos b)---- TODO: make a field of Faction?-fightsAgainstSpawners :: MonadStateRead m => FactionId -> m Bool-fightsAgainstSpawners fid = do-  fact <- getsState $ (EM.! fid) . sfactionD-  dungeon <- getsState sdungeon-  let escape = any lescape $ EM.elems dungeon-  return $! escape && keepArenaFact fact
− Game/LambdaHack/Common/Msg.hs 
@@ -1,259 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Game messages displayed on top of the screen for the player to read.-module Game.LambdaHack.Common.Msg-  ( makePhrase, makeSentence-  , Msg, (<>), (<+>), tshow, toWidth, moreMsg, yesnoMsg, truncateMsg-  , Report, emptyReport, nullReport, singletonReport, addMsg-  , splitReport, renderReport, findInReport, lastMsgOfReport-  , History, emptyHistory, lengthHistory, singletonHistory, mergeHistory-  , addReport, renderHistory, takeHistory, lastReportOfHistory-  , Overlay(overlay), emptyOverlay, truncateToOverlay, toOverlay-  , Slideshow(slideshow), splitOverlay, toSlideshow-  , encodeLine, encodeOverlay, ScreenLine, toScreenLine, splitText-  )-  where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.ByteString.Char8 as BS-import Data.Int (Int32)-import Data.List-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8, encodeUtf8)-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Unboxed as U-import qualified NLP.Miniutter.English as MU-import qualified Text.Show.Pretty as Show.Pretty--import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point--infixr 6 <+>  -- TODO: not needed when we require a very new minimorph-(<+>) :: Text -> Text -> Text-(<+>) = (MU.<+>)---- Pretty print and pack the result of @show@.-tshow :: Show a => a -> Text-tshow x = T.pack $ Show.Pretty.ppShow x--toWidth :: Int -> Text -> Text-toWidth n x = T.take n (T.justifyLeft n ' ' x)---- | Re-exported English phrase creation functions, applied to default--- irregular word sets.-makePhrase, makeSentence :: [MU.Part] -> Text-makePhrase = MU.makePhrase MU.defIrregular-makeSentence = MU.makeSentence MU.defIrregular---- | The type of a single message.-type Msg = Text---- | The \"press something to see more\" mark.-moreMsg :: Msg-moreMsg = "--more--  "---- | The confirmation request message.-yesnoMsg :: Msg-yesnoMsg = "[yn]"---- | Add a space at the message end, for display overlayed over the level map.--- Also trims (does not wrap!) too long lines. In case of newlines,--- displays only the first line, but marks the message as partial.-truncateMsg :: X -> Text -> Text-truncateMsg w xsRaw =-  let xs = case T.lines xsRaw of-        [] -> xsRaw-        [line] -> line-        line : _ -> T.justifyLeft (w + 1) ' ' line-      len = T.length xs-  in case compare w len of-       LT -> T.snoc (T.take (w - 1) xs) '$'-       EQ -> xs-       GT -> if T.null xs || T.last xs == ' '-             then xs-             else T.snoc xs ' '---- | The type of a set of messages to show at the screen at once.-newtype Report = Report [(BS.ByteString, Int)]-  deriving (Show, Binary)---- | Empty set of messages.-emptyReport :: Report-emptyReport = Report []---- | Test if the set of messages is empty.-nullReport :: Report -> Bool-nullReport (Report l) = null l---- | Construct a singleton set of messages.-singletonReport :: Msg -> Report-singletonReport = addMsg emptyReport---- TODO: Differentiate from msgAdd. Generally, invent more informative names.--- | Add message to the end of report.-addMsg :: Report -> Msg -> Report-addMsg r m | T.null m = r-addMsg (Report ((x, n) : xns)) y' | x == y =-  Report $ (y, n + 1) : xns- where y = encodeUtf8 y'-addMsg (Report xns) y = Report $ (encodeUtf8 y, 1) : xns---- | Split a messages into chunks that fit in one line.--- We assume the width of the messages line is the same as of level map.-splitReport :: X -> Report -> Overlay-splitReport w r = toOverlay $ splitReportList w r--splitReportList :: X -> Report -> [Text]-splitReportList w r = splitText w $ renderReport r---- | Render a report as a (possibly very long) string.-renderReport :: Report  -> Text-renderReport (Report []) = T.empty-renderReport (Report (xn : xs)) =-  renderReport (Report xs) <+> renderRepetition xn--renderRepetition :: (BS.ByteString, Int) -> Text-renderRepetition (s, 1) = decodeUtf8 s-renderRepetition (s, n) = decodeUtf8 s <> "<x" <> tshow n <> ">"--findInReport :: (BS.ByteString -> Bool) -> Report -> Maybe BS.ByteString-findInReport f (Report xns) = find f $ map fst xns--lastMsgOfReport :: Report -> (BS.ByteString, Report)-lastMsgOfReport (Report rep) = case rep of-  [] -> assert `failure` rep-  (lmsg, 1) : repRest -> (lmsg, Report repRest)-  (lmsg, n) : repRest -> (lmsg, Report $ (lmsg, n - 1) : repRest)---- | Split a string into lines. Avoids ending the line with a character--- other than whitespace or punctuation. Space characters are removed--- from the start, but never from the end of lines. Newlines are respected.-splitText :: X -> Text -> [Text]-splitText w xs = concatMap (splitText' w . T.stripStart) $ T.lines xs--splitText' :: X -> Text -> [Text]-splitText' w xs-  | w >= T.length xs = [xs]  -- no problem, everything fits-  | otherwise =-      let (pre, post) = T.splitAt w xs-          (ppre, ppost) = T.break (== ' ') $ T.reverse pre-          testPost = T.stripEnd ppost-      in if T.null testPost-         then pre : splitText w post-         else T.reverse ppost : splitText w (T.reverse ppre <> post)---- | The history of reports.-newtype History = History [Report]-  deriving (Show, Binary)---- | Empty history of reports.-emptyHistory :: History-emptyHistory = History []--lengthHistory :: History -> Int-lengthHistory (History rs) = length rs---- | Construct a singleton history of reports.-singletonHistory :: Report -> History-singletonHistory r = addReport r emptyHistory--mergeHistory :: [(Msg, History)] -> History-mergeHistory l =-  let unhist (History x) = x-      f (msg, h) = singletonReport msg : unhist h-  in History $ concatMap f l---- | Render history as many lines of text, wrapping if necessary.-renderHistory :: History -> Overlay-renderHistory (History h) =-  let w = fst normalLevelBound + 1-  in toOverlay $ concatMap (splitReportList w) h---- | Add a report to history, handling repetitions.-addReport :: Report -> History -> History-addReport (Report []) h = h-addReport m (History []) = History [m]-addReport (Report m) (History (Report h : hs)) =-  case (reverse m, h) of-    ((s1, n1) : rs, (s2, n2) : hhs) | s1 == s2 ->-      let hist = Report ((s2, n1 + n2) : hhs) : hs-      in History $ if null rs then hist else Report (reverse rs) : hist-    _ -> History $ Report m : Report h : hs---- | Take the given prefix of reports from a history.-takeHistory :: Int -> History -> History-takeHistory k (History h) = History $ take k h--lastReportOfHistory :: History -> Maybe Report-lastReportOfHistory (History hist) = case hist of-  [] -> Nothing-  rep : _ -> Just rep--type ScreenLine = U.Vector Int32--toScreenLine :: Text -> ScreenLine-toScreenLine t = let f c = AttrChar defAttr c-                 in encodeLine $ map f $ T.unpack t--encodeLine :: [AttrChar] -> ScreenLine-encodeLine l = G.fromList $ map (fromIntegral . fromEnum) l--encodeOverlay :: [[AttrChar]] -> Overlay-encodeOverlay = Overlay . map encodeLine---- | A series of screen lines that may or may not fit the width nor height--- of the screen. An overlay may be transformed by adding the first line--- and/or by splitting into a slideshow of smaller overlays.-newtype Overlay = Overlay {overlay :: [ScreenLine]}-  deriving (Show, Eq, Binary)--emptyOverlay :: Overlay-emptyOverlay = Overlay []--truncateToOverlay :: Text -> Overlay-truncateToOverlay msg = toOverlay [msg]--toOverlay :: [Text] -> Overlay-toOverlay = let lxsize = fst normalLevelBound + 1  -- TODO-            in Overlay . map toScreenLine . map (truncateMsg lxsize)---- | Split an overlay into a slideshow in which each overlay,--- prefixed by @msg@ and postfixed by @moreMsg@ except for the last one,--- fits on the screen wrt height (but lines may be too wide).-splitOverlay :: Bool -> Y -> Overlay -> Overlay -> Slideshow-splitOverlay onBlank yspace (Overlay msg) (Overlay ls) =-  let len = length msg-  in if len >= yspace-     then  -- no space left for @ls@-       Slideshow (onBlank, [Overlay $ take (yspace - 1) msg-                                      ++ [toScreenLine moreMsg]])-     else let splitO over =-                let (pre, post) = splitAt (yspace - 1) $ msg ++ over-                in if null (drop 1 post)  -- (don't call @length@ on @ls@)-                   then [Overlay $ msg ++ over]  -- all fits on one screen-                   else let rest = splitO post-                        in Overlay (pre ++ [toScreenLine moreMsg]) : rest-          in Slideshow (onBlank, splitO ls)---- | A few overlays, displayed one by one upon keypress.--- When displayed, they are trimmed, not wrapped--- and any lines below the lower screen edge are not visible.--- If the boolean flag is set, the overlay is displayed over a blank screen,--- including the bottom lines.-newtype Slideshow = Slideshow {slideshow :: (Bool, [Overlay])}-  deriving (Show, Eq)--instance Monoid Slideshow where-  mempty = Slideshow (False, [])-  mappend (Slideshow (b1, l1)) (Slideshow (b2, l2)) =-    Slideshow (b1 || b2, l1 ++ l2)---- | Declare the list of raw overlays to be fit for display on the screen.--- In particular, current @Report@ is eiter empty or unimportant--- or contained in the overlays and if any vertical or horizontal--- trimming of the overlays happens, this is intended.-toSlideshow :: Bool -> [[Text]] -> Slideshow-toSlideshow onBlank l = Slideshow (onBlank, map toOverlay l)
− Game/LambdaHack/Common/Perception.hs 
@@ -1,84 +0,0 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}--- | Actors perceiving other actors and the dungeon level.------ Visibility works according to KISS. Everything that player sees is real.--- There are no unmarked hidden tiles and only solid tiles can be marked,--- so there are no invisible walls and to pass through an illusory wall,--- you have use a turn bumping into it first. Only tiles marked with Suspect--- can turn out to be another tile. (So, if all tiles are marked with--- Suspect, the player knows nothing for sure, but this should be avoided,--- because searching becomes too time-consuming.)--- Each actor sees adjacent tiles, even when blind, so adjacent tiles are--- known, so the actor can decide accurately whether to pass thorugh--- or alter, etc.------ Items are always real and visible. Actors are real, but can be invisible.--- Invisible actors in walls can't be hit, but are hinted at when altering--- the tile, so the player can flee or block. Invisible actors in open--- space can be hit.-module Game.LambdaHack.Common.Perception-  ( Perception(Perception), PerceptionVisible(PerceptionVisible)-  , totalVisible, smellVisible-  , nullPer, addPer, diffPer-  , FactionPers, Pers-  ) where--import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Point--newtype PerceptionVisible = PerceptionVisible-    {pvisible :: ES.EnumSet Point}-  deriving (Show, Eq, Binary)---- TOOD: if really needed, optimize by representing as a set of intervals--- or a set of bitmaps, like the internal representation of IntSet.--- | The type representing the perception of a faction on a level.-data Perception = Perception-  { ptotal :: !PerceptionVisible  -- ^ sum over all actors-  , psmell :: !PerceptionVisible  -- ^ sum over actors that can smell-  }-  deriving (Show, Eq, Generic)--instance Binary Perception---- | Perception of a single faction, indexed by level identifier.-type FactionPers = EM.EnumMap LevelId Perception---- | Perception indexed by faction identifier.--- This can't be added to @FactionDict@, because clients can't see it.-type Pers = EM.EnumMap FactionId FactionPers---- | The set of tiles visible by at least one hero.-totalVisible :: Perception -> ES.EnumSet Point-totalVisible = pvisible . ptotal---- | The set of tiles smelled by at least one hero.-smellVisible :: Perception -> ES.EnumSet Point-smellVisible = pvisible . psmell--nullPer :: Perception -> Bool-nullPer per = ES.null (totalVisible per) && ES.null (smellVisible per)--addPer :: Perception -> Perception -> Perception-addPer per1 per2 =-  Perception-    { ptotal = PerceptionVisible-               $ totalVisible per1 `ES.union` totalVisible per2-    , psmell = PerceptionVisible-               $ smellVisible per1 `ES.union` smellVisible per2-    }--diffPer :: Perception -> Perception -> Perception-diffPer per1 per2 =-  Perception-    { ptotal = PerceptionVisible-               $ totalVisible per1 ES.\\ totalVisible per2-    , psmell = PerceptionVisible-               $ smellVisible per1 ES.\\ smellVisible per2-    }
− Game/LambdaHack/Common/Point.hs 
@@ -1,136 +0,0 @@--- | Basic operations on 2D points represented as linear offsets.-module Game.LambdaHack.Common.Point-  ( X, Y, Point(..), maxLevelDimExponent-  , chessDist, euclidDistSq, adjacent, inside, bla, fromTo-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.))-import Data.Int (Int32)---- | Spacial dimension for points and vectors.-type X = Int---- | Spacial dimension for points and vectors.-type Y = Int---- | 2D points in cartesian representation. Coordinates grow to the right--- and down, so that the (0, 0) point is in the top-left corner of the screen.--- Coordinates are never negative.-data Point = Point-  { px :: !X-  , py :: !Y-  }-  deriving (Eq, Ord)--instance Show Point where-  show (Point x y) = show (x, y)--instance Binary Point where-  put = put . (fromIntegral :: Int -> Int32) . fromEnum-  get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get---- This conversion cannot be used for PointArray indexing,--- because it is not contiguous --- we don't know the horizontal--- width of the levels nor of the screen.--- The conversion is implemented mainly for @EnumMap@ and @EnumSet@.-instance Enum Point where-  fromEnum = fromEnumPoint-  toEnum = toEnumPoint---- | The maximum number of bits for level X and Y dimension (16).--- The value is chosen to support architectures with 32-bit Ints.-maxLevelDimExponent :: Int-{-# INLINE maxLevelDimExponent #-}-maxLevelDimExponent = 16---- | Maximal supported level X and Y dimension. Not checked anywhere.--- The value is chosen to support architectures with 32-bit Ints.-maxLevelDim :: Int-{-# INLINE maxLevelDim #-}-maxLevelDim = 2 ^ maxLevelDimExponent - 1--fromEnumPoint :: Point -> Int-{-# INLINE fromEnumPoint #-}-fromEnumPoint (Point x y) =-  assert (x >= 0 && y >= 0 `blame` "invalid point coordinates"-                           `twith` (x, y))-  $ x + unsafeShiftL y maxLevelDimExponent--toEnumPoint :: Int -> Point-{-# INLINE toEnumPoint #-}-toEnumPoint n =-  Point (n .&. maxLevelDim) (unsafeShiftR n maxLevelDimExponent)---- | The distance between two points in the chessboard metric.-chessDist :: Point -> Point -> Int-{-# INLINE chessDist #-}-chessDist (Point x0 y0) (Point x1 y1) = max (abs (x1 - x0)) (abs (y1 - y0))---- | Squared euclidean distance between two points.-euclidDistSq :: Point -> Point -> Int-{-# INLINE euclidDistSq #-}-euclidDistSq (Point x0 y0) (Point x1 y1) =-  let square n = n ^ (2 :: Int)-  in square (x1 - x0) + square (y1 - y0)---- | Checks whether two points are adjacent on the map--- (horizontally, vertically or diagonally).-adjacent :: Point -> Point -> Bool-{-# INLINE adjacent #-}-adjacent s t = chessDist s t == 1---- | Checks that a point belongs to an area.-inside :: Point -> (X, Y, X, Y) -> Bool-{-# INLINE inside #-}-inside (Point x y) (x0, y0, x1, y1) = x1 >= x && x >= x0 && y1 >= y && y >= y0---- | Bresenham's line algorithm generalized to arbitrary starting @eps@--- (@eps@ value of 0 gives the standard BLA).--- Skips the source point and goes through the second point--- to the edge of the level. GIves @Nothing@ if the points are equal.--- The target is given as @Point@ to permit aiming out of the level,--- e.g., to get uniform distributions of directions for explosions--- close to the edge of the level.-bla :: X -> Y -> Int -> Point -> Point -> Maybe [Point]-bla lxsize lysize eps source target =-  if source == target then Nothing-  else Just $-    let inBounds p@(Point x y) =-          lxsize > x && x >= 0 && lysize > y && y >= 0 && p /= source-    in takeWhile inBounds $ tail $ blaXY eps source target---- | Bresenham's line algorithm generalized to arbitrary starting @eps@--- (@eps@ value of 0 gives the standard BLA). Includes the source point--- and goes through the target point to infinity.-blaXY :: Int -> Point -> Point -> [Point]-blaXY eps (Point x0 y0) (Point x1 y1) =-  let (dx, dy) = (x1 - x0, y1 - y0)-      xyStep b (x, y) = (x + signum dx,     y + signum dy * b)-      yxStep b (x, y) = (x + signum dx * b, y + signum dy)-      (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep)-                   | otherwise       = (abs dx, abs dy, yxStep)-      bw = balancedWord p q (eps `mod` max 1 q)-      walk w xy = xy : walk (tail w) (step (head w) xy)-  in map (uncurry Point) $ walk bw (x0, y0)---- | See <http://roguebasin.roguelikedevelopment.org/index.php/Digital_lines>.-balancedWord :: Int -> Int -> Int -> [Int]-balancedWord p q eps | eps + p < q = 0 : balancedWord p q (eps + p)-balancedWord p q eps               = 1 : balancedWord p q (eps + p - q)---- | A list of all points on a straight vertical or straight horizontal line--- between two points. Fails if no such line exists.-fromTo :: Point -> Point -> [Point]-fromTo (Point x0 y0) (Point x1 y1) =- let fromTo1 :: Int -> Int -> [Int]-     fromTo1 z0 z1-       | z0 <= z1  = [z0..z1]-       | otherwise = [z0,z0-1..z1]-     result-       | x0 == x1 = map (\ y -> Point x0 y) (fromTo1 y0 y1)-       | y0 == y1 = map (\ x -> Point x y0) (fromTo1 x0 x1)-       | otherwise = assert `failure` "diagonal fromTo"-                            `twith` ((x0, y0), (x1, y1))- in result
− Game/LambdaHack/Common/PointArray.hs 
@@ -1,139 +0,0 @@--- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@.-module Game.LambdaHack.Common.PointArray-  ( Array-  , (!), (//), replicateA, replicateMA, generateMA, sizeA-  , foldlA, ifoldlA, imapA, minIndexA, minLastIndexA, maxIndexA, maxLastIndexA-  ) where--import Control.Arrow ((***))-import Control.Monad-import Data.Binary-import Data.Vector.Binary ()-import qualified Data.Vector.Fusion.Stream as Stream-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Unboxed as U--import Game.LambdaHack.Common.Point---- TODO: for now, until there's support for GeneralizedNewtypeDeriving--- for Unboxed, there's a lot of @Word8@ in place of @c@ here--- and a contraint @Enum c@ instead of @Unbox c@.---- TODO: perhaps make them an instance of Data.Vector.Generic?--- | Arrays indexed by @Point@.-data Array c = Array-  { axsize  :: X-  , aysize  :: Y-  , avector :: U.Vector Word8-  }-  deriving Eq--instance Show (Array c) where-  show a = "PointArray.Array with size " ++ show (sizeA a)--cnv :: (Enum a, Enum b) => a -> b-cnv = toEnum . fromEnum--pindex :: X -> Point -> Int-pindex xsize (Point x y) = x + y * xsize--punindex :: X -> Int -> Point-punindex xsize n = let (y, x) = n `quotRem` xsize-                   in Point x y---- Note: there's no point specializing this to @Point@ arguments,--- since the extra few additions in @fromPoint@ may be less expensive than--- memory or register allocations needed for the extra @Int@ in @Point@.--- | Array lookup.-(!) :: Enum c => Array c -> Point -> c-{-# INLINE (!) #-}-(!) Array{..} p = cnv $ avector U.! pindex axsize p---- | Construct an array updated with the association list.-(//) :: Enum c => Array c -> [(Point, c)] -> Array c-(//) Array{..} l = let v = avector U.// map (pindex axsize *** cnv) l-                   in Array{avector = v, ..}---- | Create an array from a replicated element.-replicateA :: Enum c => X -> Y -> c -> Array c-replicateA axsize aysize c =-  Array{avector = U.replicate (axsize * aysize) $ cnv c, ..}---- | Create an  array from a replicated monadic action.-replicateMA :: Enum c => Monad m => X -> Y -> m c -> m (Array c)-replicateMA axsize aysize m = do-  v <- U.replicateM (axsize * aysize) $ liftM cnv m-  return $! Array{avector = v, ..}---- | Create an array from a monadic function.-generateMA :: Enum c => Monad m => X -> Y -> (Point -> m c) -> m (Array c)-generateMA axsize aysize fm = do-  let gm n = liftM cnv $ fm $ punindex axsize n-  v <- U.generateM (axsize * aysize) gm-  return $! Array{avector = v, ..}---- | Content identifiers array size.-sizeA :: Array c -> (X, Y)-sizeA Array{..} = (axsize, aysize)---- | Fold left strictly over an array.-foldlA :: Enum c => (a -> c -> a) -> a -> Array c -> a-foldlA f z0 Array{..} =-  U.foldl' (\a c -> f a (cnv c)) z0 avector---- | Fold left strictly over an array--- (function applied to each element and its index).-ifoldlA :: Enum c => (a -> Point -> c -> a) -> a -> Array c -> a-ifoldlA f z0 Array{..} =-  U.ifoldl' (\a n c -> f a (punindex axsize n) (cnv c)) z0 avector---- | Map over an array (function applied to each element and its index).-imapA :: (Enum c, Enum d) => (Point -> c -> d) -> Array c -> Array d-imapA f Array{..} =-  let v = U.imap (\n c -> cnv $ f (punindex axsize n) (cnv c)) avector-  in Array{avector = v, ..}---- | Yield the point coordinates of a minimum element of the array.--- The array may not be empty.-minIndexA :: Enum c => Array c -> Point-{-# INLINE minIndexA #-}-minIndexA Array{..} = punindex axsize $ U.minIndex avector---- | Yield the point coordinates of the last minimum element of the array.--- The array may not be empty.-minLastIndexA :: Enum c => Array c -> Point-{-# INLINE minLastIndexA #-}-minLastIndexA Array{..} =-  punindex axsize-  $ fst . Stream.foldl1' imin . Stream.indexed . G.stream-  $ avector- where-  imin (i, x) (j, y) = i `seq` j `seq` if x >= y then (j, y) else (i, x)---- | Yield the point coordinates of the first maximum element of the array.--- The array may not be empty.-maxIndexA :: Enum c => Array c -> Point-{-# INLINE maxIndexA #-}-maxIndexA Array{..} = punindex axsize $ U.maxIndex avector---- | Yield the point coordinates of the last maximum element of the array.--- The array may not be empty.-maxLastIndexA :: Enum c => Array c -> Point-{-# INLINE maxLastIndexA #-}-maxLastIndexA Array{..} =-  punindex axsize-  $ fst . Stream.foldl1' imax . Stream.indexed . G.stream-  $ avector- where-  imax (i, x) (j, y) = i `seq` j `seq` if x <= y then (j, y) else (i, x)--instance Binary (Array c) where-  put Array{..} = do-    put axsize-    put aysize-    put avector-  get = do-    axsize <- get-    aysize <- get-    avector <- get-    return $! Array{..}
− Game/LambdaHack/Common/Random.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Representation of probabilities and random computations.-module Game.LambdaHack.Common.Random-  ( -- * The @Rng@ monad-    Rnd-    -- * Random operations-  , randomR, random, oneOf, frequency-    -- * Fractional chance-  , Chance, chance-    -- * Casting dice scaled with level-  , castDice, chanceDice, castDiceXY-  ) where--import Control.Exception.Assert.Sugar-import qualified Control.Monad.State as St-import Data.Ratio-import qualified System.Random as R--import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Misc---- | The monad of computations with random generator state.--- The lazy state monad is OK here: the state is small and regularly forced.-type Rnd a = St.State R.StdGen a---- | Get a random object within a range with a uniform distribution.-randomR :: (R.Random a) => (a, a) -> Rnd a-randomR range = St.state $ R.randomR range---- | Get a random object of a given type with a uniform distribution.-random :: (R.Random a) => Rnd a-random = St.state R.random---- | Get any element of a list with equal probability.-oneOf :: [a] -> Rnd a-oneOf [] = assert `failure` "oneOf []" `twith` ()-oneOf xs = do-  r <- randomR (0, length xs - 1)-  return (xs !! r)---- | Gen an element according to a frequency distribution.-frequency :: Show a => Frequency a -> Rnd a-frequency fr = St.state $ rollFreq fr---- | Randomly choose an item according to the distribution.-rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen)-rollFreq fr g = case runFrequency fr of-  [] -> assert `failure` "choice from an empty frequency"-               `twith` nameFrequency fr-  [(n, x)] | n <= 0 -> assert `failure` "singleton void frequency"-                                 `twith` (nameFrequency fr, n, x)-  [(_, x)] -> (x, g)  -- speedup-  fs -> let sumf = sum (map fst fs)-            (r, ng) = R.randomR (1, sumf) g-            frec :: Int -> [(Int, a)] -> a-            frec m [] = assert `failure` "impossible roll"-                               `twith` (nameFrequency fr, fs, m)-            frec m ((n, x) : _)  | m <= n = x-            frec m ((n, _) : xs) = frec (m - n) xs-        in assert (sumf > 0 `blame` "frequency with nothing to pick"-                            `twith` (nameFrequency fr, fs))-             (frec r fs, ng)---- | Fractional chance.-type Chance = Rational---- | Give @True@, with probability determined by the fraction.-chance :: Chance -> Rnd Bool-chance r = do-  let n = numerator r-      d = denominator r-  k <- randomR (1, d)-  return (k <= n)---- | Cast dice scaled with current level depth.--- Note that at the first level, the scaled dice are always ignored.-castDice :: AbsDepth -> AbsDepth -> Dice.Dice -> Rnd Int-castDice (AbsDepth n) (AbsDepth depth) dice = do-  assert (n >= 0 && n <= depth `blame` "invalid depth for dice rolls"-                               `twith` (n, depth)) skip-  dc <- frequency $ Dice.diceConst dice-  dl <- frequency $ Dice.diceLevel dice-  return $! (dc + (dl * max 0 (n - 1)) `div` max 1 (depth - 1))-            * Dice.diceScale dice---- | Cast dice scaled with current level depth and return @True@--- if the results is greater than 50.-chanceDice :: AbsDepth -> AbsDepth -> Dice.Dice -> Rnd Bool-chanceDice ldepth totalDepth dice = do-  c <- castDice ldepth totalDepth dice-  return $! c > 50---- | Cast dice, scaled with current level depth, for coordinates.-castDiceXY :: AbsDepth -> AbsDepth -> Dice.DiceXY -> Rnd (Int, Int)-castDiceXY ldepth totalDepth (Dice.DiceXY dx dy) = do-  x <- castDice ldepth totalDepth dx-  y <- castDice ldepth totalDepth dy-  return (x, y)
− Game/LambdaHack/Common/Request.hs 
@@ -1,118 +0,0 @@-{-# LANGUAGE ExistentialQuantification, GADTs, StandaloneDeriving, DataKinds, KindSignatures #-}--- | Abstract syntax of server commands.--- See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Common.Request-  ( RequestAI(..), RequestUI(..), RequestTimed(..), RequestAnyAbility(..)-  , ReqFailure(..), showReqFailure, anyToUI-  ) where--import Data.Text (Text)--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Common.Ability---- TODO: make remove second arg from ReqLeader; this requires a separate--- channel for Ping, probably, and then client sends as many commands--- as it wants at once--- | Cclient-server requests sent by AI clients.-data RequestAI =-    forall a. ReqAITimed !(RequestTimed a)-  | ReqAILeader !ActorId !RequestAI-  | ReqAIPong--deriving instance Show RequestAI---- | Client-server requests sent by UI clients.-data RequestUI =-    forall a. ReqUITimed !(RequestTimed a)-  | ReqUILeader !ActorId !RequestUI-  | ReqUIGameRestart !ActorId !Text !Int ![(Int, (Text, Text))]-  | ReqUIGameExit !ActorId !Int-  | ReqUIGameSave-  | ReqUIAutomate-  | ReqUIPong [CmdAtomic]--deriving instance Show RequestUI--data RequestAnyAbility = forall a. RequestAnyAbility !(RequestTimed a)--deriving instance Show RequestAnyAbility--anyToUI :: RequestAnyAbility -> RequestUI-anyToUI (RequestAnyAbility cmd) = ReqUITimed cmd---- | Client-server requests that take game time. Sent by both AI and UI clients.-data RequestTimed :: Ability -> * where-  ReqMove :: !Vector -> RequestTimed AbMove-  ReqMelee :: !ActorId -> !ItemId -> !CStore -> RequestTimed AbMelee-  ReqDisplace :: !ActorId -> RequestTimed AbDisplace-  ReqAlter :: !Point -> !(Maybe F.Feature) -> RequestTimed AbAlter-  ReqWait :: RequestTimed AbWait-  ReqMoveItem :: !ItemId -> !Int -> !CStore -> !CStore-              -> RequestTimed AbMoveItem-  ReqProject :: !Point -> !Int -> !ItemId -> !CStore -> RequestTimed AbProject-  ReqApply :: !ItemId -> !CStore -> RequestTimed AbApply-  ReqTrigger :: !(Maybe F.Feature) -> RequestTimed AbTrigger--deriving instance Show (RequestTimed a)--data ReqFailure =-    MoveNothing-  | MeleeSelf-  | MeleeDistant-  | DisplaceDistant-  | DisplaceAccess-  | DisplaceProjectiles-  | DisplaceDying-  | DisplaceBraced-  | DisplaceSupported-  | AlterDistant-  | AlterBlockActor-  | AlterBlockItem-  | AlterNothing-  | EqpOverfull-  | DurablePeriodicAbuse-  | ApplyBlind-  | ApplyOutOfReach-  | ItemNothing-  | ItemNotCalm-  | ProjectAimOnself-  | ProjectBlockTerrain-  | ProjectBlockActor-  | ProjectBlind-  | TriggerNothing--showReqFailure :: ReqFailure -> Msg-showReqFailure reqFailure = case reqFailure of-  MoveNothing -> "wasting time on moving into obstacle"-  MeleeSelf -> "trying to melee oneself"-  MeleeDistant -> "trying to melee a distant foe"-  DisplaceDistant -> "trying to switch places with a distant actor"-  DisplaceAccess -> "switching places without access"-  DisplaceProjectiles -> "trying to switch places with multiple projectiles"-  DisplaceDying -> "trying to switch places with a dying foe"-  DisplaceBraced -> "trying to switch places with a braced foe"-  DisplaceSupported -> "trying to switch places with a supported foe"-  AlterDistant -> "trying to alter a distant tile"-  AlterBlockActor -> "blocked by an actor"-  AlterBlockItem -> "jammed by an item"-  AlterNothing -> "wasting time on altering nothing"-  EqpOverfull -> "cannot equip any more items"-  DurablePeriodicAbuse -> "cannot apply a durable periodic item"-  ApplyBlind -> "blind actors cannot read"-  ApplyOutOfReach -> "cannot apply an item out of reach"-  ItemNothing -> "wasting time on void item manipulation"-  ItemNotCalm -> "you are too alarmed to sort through the shared stash"-  ProjectAimOnself -> "cannot aim at oneself"-  ProjectBlockTerrain -> "aiming obstructed by terrain"-  ProjectBlockActor -> "aiming blocked by an actor"-  ProjectBlind -> "blind actors cannot aim"-  TriggerNothing -> "wasting time on triggering nothing"
− Game/LambdaHack/Common/Response.hs 
@@ -1,24 +0,0 @@--- | Abstract syntax of client commands.--- See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Common.Response-  ( ResponseAI(..), ResponseUI(..)-  ) where--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor---- | Abstract syntax of client commands that don't use the UI.-data ResponseAI =-    RespUpdAtomicAI !UpdAtomic-  | RespQueryAI !ActorId-  | RespPingAI-  deriving Show---- | Abstract syntax of client commands that use the UI.-data ResponseUI =-    RespUpdAtomicUI !UpdAtomic-  | RespSfxAtomicUI !SfxAtomic-  | RespQueryUI-  | RespPingUI-  deriving Show
− Game/LambdaHack/Common/Save.hs 
@@ -1,115 +0,0 @@--- | Saving and restoring server game state.-module Game.LambdaHack.Common.Save-  ( ChanSave, saveToChan, wrapInSaves, restoreGame, delayPrint-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import qualified Control.Exception as Ex hiding (handle)-import Control.Monad-import Data.Binary-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import System.Directory-import System.FilePath-import System.IO-import qualified System.Random as R--import Game.LambdaHack.Common.File-import Game.LambdaHack.Common.Msg--type ChanSave a = MVar (Maybe a)--saveToChan :: ChanSave a -> a -> IO ()-saveToChan toSave s = do-  -- Wipe out previous candidates for saving.-  void $ tryTakeMVar toSave-  putMVar toSave $ Just s---- TODO: to have crash saves, send state to server save channel each turn--- and have another mvar, asking for a save with the last state;--- this mvar is permanently true on clients, but only set on server--- in finally and each time bkp save is requested; finally should also--- send save request to all clients (using the last state from the save--- channel for client connection data, etc.)--- All this is not needed if we bkp save each turn, but that's costly.---- | Repeatedly save a simple serialized version of the current state.-loopSave :: Binary a => (a -> FilePath) -> ChanSave a -> IO ()-loopSave saveFile toSave =-  loop- where-  loop = do-    -- Wait until anyting to save.-    ms <- takeMVar toSave-    case ms of-      Just s -> do-        dataDir <- appDataDir-        tryCreateDir (dataDir </> "saves")-        encodeEOF (dataDir </> "saves" </> saveFile s) s-        -- Wait until the save finished. During that time, the mvar-        -- is continually updated to newest state values.-        loop-      Nothing -> return ()  -- exit--wrapInSaves :: Binary a => (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()-wrapInSaves saveFile exe = do-  -- We don't merge this with the other calls to waitForChildren,-  -- because, e.g., for server, we don't want to wait for clients to exit,-  -- if the server crashes (but we wait for the save to finish).-  toSave <- newEmptyMVar-  a <- async $ loopSave saveFile toSave-  link a-  let fin = do-        -- Wait until the last save (if any) starts-        -- and tell the save thread to end.-        putMVar toSave Nothing-        -- Wait 0.5s to flush debug and then until the save thread ends.-        threadDelay 500000-        wait a-  exe toSave `Ex.finally` fin-  -- The creation of, e.g., the initial client state, is outside the 'finally'-  -- clause, but this is OK, since no saves are ordered until 'runActionCli'.-  -- We save often, not only in the 'finally' section, in case of-  -- power outages, kill -9, GHC runtime crashes, etc. For internal game-  -- crashes, C-c, etc., the finalizer would be enough.-  -- If we implement incremental saves, saving often will help-  -- to spread the cost, to avoid a long pause at game exit.---- | Restore a saved game, if it exists. Initialize directory structure--- and cope over data files, if needed.-restoreGame :: Binary a-            => String -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath)-            -> IO (Maybe a)-restoreGame name copies pathsDataFile = do-  -- Create user data directory and copy files, if not already there.-  dataDir <- appDataDir-  tryCreateDir dataDir-  tryCopyDataFiles dataDir pathsDataFile copies-  let saveFile = dataDir </> "saves" </> name-  saveExists <- doesFileExist saveFile-  -- If the savefile exists but we get IO or decoding errors,-  -- we show them and start a new game. If the savefile was randomly-  -- corrupted or made read-only, that should solve the problem.-  -- OTOH, serious IO problems (e.g. failure to create a user data directory)-  -- terminate the program with an exception.-  res <- Ex.try $-    if saveExists then do-      s <- strictDecodeEOF saveFile-      return $ Just s-    else return Nothing-  let handler :: Ex.SomeException -> IO (Maybe a)-      handler e = do-        let msg = "Restore failed. The error message is:"-                  <+> (T.unwords . T.lines) (tshow e)-        delayPrint $ msg-        return Nothing-  either handler return res--delayPrint :: Text -> IO ()-delayPrint t = do-  delay <- R.randomRIO (0, 1000000)-  threadDelay delay  -- try not to interleave saves with other clients-  T.hPutStrLn stderr t-  hFlush stderr
− Game/LambdaHack/Common/State.hs 
@@ -1,195 +0,0 @@--- | Server and client game state types and operations.-module Game.LambdaHack.Common.State-  ( -- * Basic game state, local or global-    State-    -- * State components-  , sdungeon, stotalDepth, sactorD, sitemD, sfactionD, stime, scops, shigh-    -- * State operations-  , defStateGlobal, emptyState, localFromGlobal-  , updateDungeon, updateDepth, updateActorD, updateItemD-  , updateFactionD, updateTime, updateCOps-  ) where--import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.Text (Text)--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.TileKind---- | View on game state. "Remembered" fields carry a subset of the info--- in the client copies of the state. Clients never directly change--- their @State@, but apply atomic actions sent by the server to do so.-data State = State-  { _sdungeon    :: !Dungeon      -- ^ remembered dungeon-  , _stotalDepth :: !AbsDepth     -- ^ absolute dungeon depth, for item creation-  , _sactorD     :: !ActorDict    -- ^ remembered actors in the dungeon-  , _sitemD      :: !ItemDict     -- ^ remembered items in the dungeon-  , _sfactionD   :: !FactionDict  -- ^ remembered sides still in game-  , _stime       :: !Time         -- ^ global game time-  , _scops       :: Kind.COps     -- ^ remembered content-  , _shigh       :: !HighScore.ScoreTable  -- ^ high score table-  }-  deriving (Show, Eq)---- TODO: add a flag 'fresh' and when saving levels, don't save--- and when loading regenerate this level.-unknownLevel :: Kind.Ops TileKind -> AbsDepth -> X -> Y-             -> Text -> ([Point], [Point]) -> Int -> Int -> Int -> Bool-             -> Level-unknownLevel Kind.Ops{ouniqGroup} ldepth lxsize lysize ldesc lstair lclear-             lsecret lhidden lescape =-  let unknownId = ouniqGroup "unknown space"-      outerId = ouniqGroup "basic outer fence"-  in Level { ldepth-           , lprio = EM.empty-           , lfloor = EM.empty-           , ltile = unknownTileMap unknownId outerId lxsize lysize-           , lxsize-           , lysize-           , lsmell = EM.empty-           , ldesc-           , lstair-           , lseen = 0-           , lclear-           , ltime = timeZero-           , lactorFreq = []-           , litemNum = 0-           , litemFreq = []-           , lsecret-           , lhidden-           , lescape-           }--unknownTileMap :: Kind.Id TileKind -> Kind.Id TileKind -> Int -> Int -> TileMap-unknownTileMap unknownId outerId lxsize lysize =-  let unknownMap = PointArray.replicateA lxsize lysize unknownId-      borders = [ Point x y-                | x <- [0, lxsize - 1], y <- [1..lysize - 2] ]-                ++ [ Point x y-                   | x <- [0..lxsize - 1], y <- [0, lysize - 1] ]-      outerUpdate = zip borders $ repeat outerId-  in unknownMap PointArray.// outerUpdate---- | Initial complete global game state.-defStateGlobal :: Dungeon -> AbsDepth-               -> FactionDict -> Kind.COps -> HighScore.ScoreTable-               -> State-defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh =-  State-    { _sactorD = EM.empty-    , _sitemD = EM.empty-    , _stime = timeZero-    , ..-    }---- | Initial empty state.-emptyState :: State-emptyState =-  State-    { _sdungeon = EM.empty-    , _stotalDepth = AbsDepth 0-    , _sactorD = EM.empty-    , _sitemD = EM.empty-    , _sfactionD = EM.empty-    , _stime = timeZero-    , _scops = undefined-    , _shigh = HighScore.empty-    }---- TODO: make lstair secret until discovered; use this later on for--- goUp in targeting mode (land on stairs of on the same location up a level--- if this set of stsirs is unknown).--- | Local state created by removing secret information from global--- state components.-localFromGlobal :: State -> State-localFromGlobal State{_scops=_scops@Kind.COps{cotile}, .. } =-  State-    { _sdungeon =-      EM.map (\Level{..} ->-              unknownLevel cotile ldepth lxsize lysize ldesc lstair lclear-                           lsecret lhidden lescape)-            _sdungeon-    , ..-    }---- | Update dungeon data within state.-updateDungeon :: (Dungeon -> Dungeon) -> State -> State-updateDungeon f s = s {_sdungeon = f (_sdungeon s)}---- | Update dungeon depth.-updateDepth :: (AbsDepth -> AbsDepth) -> State -> State-updateDepth f s = s {_stotalDepth = f (_stotalDepth s)}---- | Update the actor dictionary.-updateActorD :: (ActorDict -> ActorDict) -> State -> State-updateActorD f s = s {_sactorD = f (_sactorD s)}---- | Update the item dictionary.-updateItemD :: (ItemDict -> ItemDict) -> State -> State-updateItemD f s = s {_sitemD = f (_sitemD s)}---- | Update faction data within state.-updateFactionD :: (FactionDict -> FactionDict) -> State -> State-updateFactionD f s = s {_sfactionD = f (_sfactionD s)}---- | Update global time within state.-updateTime :: (Time -> Time) -> State -> State-updateTime f s = s {_stime = f (_stime s)}---- | Update content data within state.-updateCOps :: (Kind.COps -> Kind.COps) -> State -> State-updateCOps f s = s {_scops = f (_scops s)}--sdungeon :: State -> Dungeon-sdungeon = _sdungeon--stotalDepth :: State -> AbsDepth-stotalDepth = _stotalDepth--sactorD :: State -> ActorDict-sactorD = _sactorD--sitemD :: State -> ItemDict-sitemD = _sitemD--sfactionD :: State -> FactionDict-sfactionD = _sfactionD--stime :: State -> Time-stime = _stime--scops :: State -> Kind.COps-scops = _scops--shigh :: State -> HighScore.ScoreTable-shigh = _shigh--instance Binary State where-  put State{..} = do-    put _sdungeon-    put _stotalDepth-    put _sactorD-    put _sitemD-    put _sfactionD-    put _stime-    put _shigh-  get = do-    _sdungeon <- get-    _stotalDepth <- get-    _sactorD <- get-    _sitemD <- get-    _sfactionD <- get-    _stime <- get-    _shigh <- get-    let _scops = undefined  -- overwritten by recreated cops-    return $! State{..}
− Game/LambdaHack/Common/Thread.hs 
@@ -1,26 +0,0 @@--- | Keeping track of forked threads.-module Game.LambdaHack.Common.Thread-  ( forkChild, waitForChildren-  ) where--import Control.Concurrent.Async-import Control.Concurrent.MVar---- Swiped from http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html. Ported to Async to link exceptions, to let travis tests fail.--forkChild :: MVar [Async ()] -> IO () -> IO ()-forkChild children io = do-  a <- async io-  link a-  childs <- takeMVar children-  putMVar children (a : childs)--waitForChildren :: MVar [Async ()] -> IO ()-waitForChildren children = do-  cs <- takeMVar children-  case cs of-    [] -> return ()-    m : ms -> do-      putMVar children ms-      wait m-      waitForChildren children
− Game/LambdaHack/Common/Tile.hs 
@@ -1,226 +0,0 @@--- | Operations concerning dungeon level tiles.------ Unlike for many other content types, there is no type @Tile@,--- of particular concrete tiles in the dungeon,--- corresponding to 'TileKind' (the type of kinds of terrain tiles).--- This is because the tiles are too numerous and there's not enough--- storage space for a well-rounded @Tile@ type, on one hand,--- and on the other hand, tiles are accessed--- too often in performance critical code--- to try to compress their representation and/or recompute them.--- Instead, of defining a @Tile@ type, we express various properties--- of concrete tiles by arrays or sparse EnumMaps, as appropriate.------ Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m).-module Game.LambdaHack.Common.Tile-  ( SmellTime-  , kindHasFeature, hasFeature-  , isClear, isLit, isWalkable, isPassableKind, isPassable, isDoor, isSuspect-  , isExplorable, lookSimilar, speedup-  , openTo, closeTo, causeEffects, revealAs, hideAs-  , isOpenable, isClosable, isChangeable, isEscape, isStair-  ) where--import Control.Exception.Assert.Sugar-import Data.Maybe--import qualified Game.LambdaHack.Common.Effect as Effect-import qualified Game.LambdaHack.Common.Feature as F-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.TileKind---- | The last time a hero left a smell in a given tile. To be used--- by monsters that hunt by smell.-type SmellTime = Time---- | Whether a tile kind has the given feature.-kindHasFeature :: F.Feature -> TileKind -> Bool-{-# INLINE kindHasFeature #-}-kindHasFeature f t = f `elem` tfeature t---- | Whether a tile kind (specified by its id) has the given feature.-hasFeature :: Kind.Ops TileKind -> F.Feature -> Kind.Id TileKind -> Bool-{-# INLINE hasFeature #-}-hasFeature Kind.Ops{okind} f t = kindHasFeature f (okind t)---- | Whether a tile does not block vision.--- Essential for efficiency of "FOV", hence tabulated.-isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isClear #-}-isClear Kind.Ops{ospeedup = Just Kind.TileSpeedup{isClearTab}} =-  \k -> Kind.accessTab isClearTab k-isClear cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether a tile is lit on its own.--- Essential for efficiency of "Perception", hence tabulated.-isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isLit #-}-isLit Kind.Ops{ospeedup = Just Kind.TileSpeedup{isLitTab}} =-  \k -> Kind.accessTab isLitTab k-isLit cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether actors can walk into a tile.--- Essential for efficiency of pathfinding, hence tabulated.-isWalkable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isWalkable #-}-isWalkable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isWalkableTab}} =-  \k -> Kind.accessTab isWalkableTab k-isWalkable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether actors can walk into a tile, perhaps opening a door first,--- perhaps a hidden door.--- Essential for efficiency of pathfinding, hence tabulated.-isPassable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isPassable #-}-isPassable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isPassableTab}} =-  \k -> Kind.accessTab isPassableTab k-isPassable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether a tile is a door, open or closed.--- Essential for efficiency of pathfinding, hence tabulated.-isDoor :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isDoor #-}-isDoor Kind.Ops{ospeedup = Just Kind.TileSpeedup{isDoorTab}} =-  \k -> Kind.accessTab isDoorTab k-isDoor cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether a tile is suspect.--- Essential for efficiency of pathfinding, hence tabulated.-isSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isSuspect #-}-isSuspect Kind.Ops{ospeedup = Just Kind.TileSpeedup{isSuspectTab}} =-  \k -> Kind.accessTab isSuspectTab k-isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether a tile kind (specified by its id) has a ChangeTo feature.--- Essential for efficiency of pathfinding, hence tabulated.-isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isChangeable #-}-isChangeable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isChangeableTab}} =-  \k -> Kind.accessTab isChangeableTab k-isChangeable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile---- | Whether one can easily explore a tile, possibly finding a treasure--- or a clue. Doors can't be explorable since revealing a secret tile--- should not change it's (walkable and) explorable status.--- Door status should not depend on whether they are open or not--- so that a foe opening a door doesn't force us to backtrack to explore it.-isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-{-# INLINE isExplorable #-}-isExplorable cotile t =-  (isWalkable cotile t || isClear cotile t) && not (isDoor cotile t)---- | The player can't tell one tile from the other.-lookSimilar :: TileKind -> TileKind -> Bool-{-# INLINE lookSimilar #-}-lookSimilar t u =-  tsymbol t == tsymbol u &&-  tname   t == tname   u &&-  tcolor  t == tcolor  u &&-  tcolor2 t == tcolor2 u--speedup :: Bool -> Kind.Ops TileKind -> Kind.Speedup TileKind-speedup allClear cotile =-  -- Vectors pack bools as Word8 by default. No idea if the extra memory-  -- taken makes random lookups more or less efficient, so not optimizing-  -- further, until I have benchmarks.-  let isClearTab | allClear = Kind.createTab cotile-                              $ not . kindHasFeature F.Impenetrable-                 | otherwise = Kind.createTab cotile-                               $ kindHasFeature F.Clear-      isLitTab = Kind.createTab cotile $ not . kindHasFeature F.Dark-      isWalkableTab = Kind.createTab cotile $ kindHasFeature F.Walkable-      isPassableTab = Kind.createTab cotile isPassableKind-      isDoorTab = Kind.createTab cotile $ \tk ->-        let getTo F.OpenTo{} = True-            getTo F.CloseTo{} = True-            getTo _ = False-        in any getTo $ tfeature tk-      isSuspectTab = Kind.createTab cotile $ kindHasFeature F.Suspect-      isChangeableTab = Kind.createTab cotile $ \tk ->-        let getTo F.ChangeTo{} = True-            getTo _ = False-        in any getTo $ tfeature tk-  in Kind.TileSpeedup {..}--isPassableKind :: TileKind -> Bool-isPassableKind tk =-  let getTo F.Walkable = True-      getTo F.OpenTo{} = True-      getTo F.ChangeTo{} = True  -- can change to passable and may have loot-      getTo F.Suspect = True-      getTo _ = False-  in any getTo $ tfeature tk--openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)-openTo Kind.Ops{okind, opick} t = do-  let getTo (F.OpenTo group) acc = group : acc-      getTo _ acc = acc-  case foldr getTo [] $ tfeature $ okind t of-    [] -> return t-    groups -> do-      group <- oneOf groups-      fmap (fromMaybe $ assert `failure` group)-        $ opick group (const True)--closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)-closeTo Kind.Ops{okind, opick} t = do-  let getTo (F.CloseTo group) acc = group : acc-      getTo _ acc = acc-  case foldr getTo [] $ tfeature $ okind t of-    [] -> return t-    groups -> do-      group <- oneOf groups-      fmap (fromMaybe $ assert `failure` group)-        $ opick group (const True)--causeEffects :: Kind.Ops TileKind -> Kind.Id TileKind -> [Effect.Effect Int]-causeEffects Kind.Ops{okind} t = do-  let getTo (F.Cause eff) acc = eff : acc-      getTo _ acc = acc-  foldr getTo [] $ tfeature $ okind t--revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind)-revealAs Kind.Ops{okind, opick} t = do-  let getTo (F.RevealAs group) acc = group : acc-      getTo _ acc = acc-  case foldr getTo [] $ tfeature $ okind t of-    [] -> return t-    groups -> do-      group <- oneOf groups-      fmap (fromMaybe $ assert `failure` group)-        $ opick group (const True)--hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind-hideAs Kind.Ops{okind, ouniqGroup} t =-  let getTo (F.HideAs group) _ = Just group-      getTo _ acc = acc-  in case foldr getTo Nothing (tfeature (okind t)) of-       Nothing    -> t-       Just group -> ouniqGroup group---- | Whether a tile kind (specified by its id) has an OpenTo feature.-isOpenable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isOpenable Kind.Ops{okind} t =-  let getTo F.OpenTo{} = True-      getTo _ = False-  in any getTo $ tfeature $ okind t---- | Whether a tile kind (specified by its id) has a CloseTo feature.-isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isClosable Kind.Ops{okind} t =-  let getTo F.CloseTo{} = True-      getTo _ = False-  in any getTo $ tfeature $ okind t--isEscape :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isEscape cotile t = let isEffectEscape Effect.Escape{} = True-                        isEffectEscape _ = False-                    in any isEffectEscape $ causeEffects cotile t--isStair :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isStair cotile t = let isEffectAscend Effect.Ascend{} = True-                       isEffectAscend _ = False-                   in any isEffectAscend $ causeEffects cotile t
− Game/LambdaHack/Common/Time.hs 
@@ -1,196 +0,0 @@-{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}--- | Game time and speed.-module Game.LambdaHack.Common.Time-  ( Time, timeZero, timeClip, timeTurn, timeEpsilon-  , absoluteTimeAdd, absoluteTimeNegate, timeFit, timeFitUp-  , Delta(..), timeShift, timeDeltaToFrom, timeDeltaReverse, timeDeltaScale-  , timeDeltaToDigit, ticksPerMeter-  , Speed, toSpeed, fromSpeed, speedZero, speedNormal-  , speedScale, speedAdd, speedNegate-  , speedFromWeight, rangeFromSpeed, rangeFromSpeedAndLinger-  ) where--import Data.Binary-import qualified Data.Char as Char-import Data.Int (Int64)--import Game.LambdaHack.Common.Misc---- | Game time in ticks. The time dimension.--- One tick is 1 microsecond (one millionth of a second),--- one turn is 0.5 s.-newtype Time = Time Int64-  deriving (Show, Eq, Ord, Enum, Bounded, Binary)---- | One-dimentional vectors. Introduced to tell apart the 2 uses of Time:--- as an absolute game time and as an increment.-newtype Delta a = Delta a-  deriving (Show, Eq, Ord, Enum, Bounded, Binary, Functor)---- | Start of the game time, or zero lenght time interval.-timeZero :: Time-timeZero = Time 0---- | The smallest unit of time. Do not export, because the proportion--- of turn to tick is an implementation detail.--- The significance of this detail is only that it determines resolution--- of the time dimension.-_timeTick :: Time-_timeTick = Time 1---- | An infinitesimal time period.-timeEpsilon :: Time-timeEpsilon = _timeTick---- TODO: don't have a fixed time, but instead set it at 1/3 or 1/4--- of timeTurn depending on level. Clips are a UI feature--- after all, so should depend on the user situation.--- | At least once per clip all moves are resolved and a frame--- or a frame delay is generated.--- Currently one clip is 0.1 s, but it may change,--- and the code should not depend on this fixed value.-timeClip :: Time-timeClip = Time 100000---- | One turn is 0.5 s. The code may depend on that.--- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m).-timeTurn :: Time-timeTurn = Time 500000---- | This many turns fit in a single second.-turnsInSecond :: Int64-turnsInSecond = 2---- | This many ticks fits in a single second. Do not export,-_ticksInSecond :: Int64-_ticksInSecond =-  let Time ticksInTurn = timeTurn-  in ticksInTurn * turnsInSecond---- | Absolute time addition, e.g., for summing the total game session time--- from the times of individual games.-absoluteTimeAdd :: Time -> Time -> Time-absoluteTimeAdd (Time t1) (Time t2) = Time (t1 + t2)---- | Shifting an absolute time by a time vector.-timeShift :: Time -> Delta Time -> Time-timeShift (Time t1) (Delta (Time t2)) = Time (t1 + t2)---- | How many time intervals of the latter kind fits in an interval--- of the former kind.-timeFit :: Time -> Time -> Int-timeFit (Time t1) (Time t2) = fromIntegral $ t1 `div` t2---- | How many time intervals of the latter kind cover an interval--- of the former kind (rounded up).-timeFitUp :: Time -> Time -> Int-timeFitUp (Time t1) (Time t2) = fromIntegral $ t1 `divUp` t2---- | Reverse a time vector.-timeDeltaReverse :: Delta Time -> Delta Time-timeDeltaReverse (Delta (Time t)) = Delta (Time (-t))---- | Absolute time negation. To be used for reversing time flow,--- e.g., for comparing absolute times in the reverse order.-absoluteTimeNegate :: Time -> Time-absoluteTimeNegate (Time t) = Time (-t)---- | Time time vector between the second and the first absolute times.--- The arguments are in the same order as in the underlying scalar subtraction.-timeDeltaToFrom :: Time -> Time -> Delta Time-timeDeltaToFrom (Time t1) (Time t2) = Delta $ Time (t1 - t2)---- | Scale the time vector by an @Int@ scalar value.-timeDeltaScale :: Delta Time -> Int -> Delta Time-timeDeltaScale (Delta (Time t)) s = Delta (Time (t * fromIntegral s))---- | Represent the main 10 thresholds of a time range by digits,--- given the total length of the time range.-timeDeltaToDigit :: Delta Time -> Delta Time -> Char-timeDeltaToDigit (Delta (Time maxT)) (Delta (Time t)) =-  let k = 10 * t `div` maxT-      digit | k > 9     = '*'-            | k < 0     = '-'-            | otherwise = Char.intToDigit $ fromIntegral k-  in digit---- | Speed in meters per 1 million seconds (m/Ms).--- Actors at normal speed (2 m/s) take one time turn (0.5 s)--- to move one tile (1 m by 1 m).-newtype Speed = Speed Int64-  deriving (Eq, Ord, Binary)--instance Show Speed where-  show s = show $ fromSpeed s---- | Number of seconds in a mega-second.-sInMs :: Int64-sInMs = 1000000---- | Constructor for content definitions.-toSpeed :: Int -> Speed-toSpeed s = Speed $ fromIntegral s * sInMs `div` 10---- | Pretty-printing of speed in the format used in content definitions.-fromSpeed :: Speed -> Int-fromSpeed (Speed s) = fromIntegral $ s * 10 `div` sInMs---- | No movement possible at that speed.-speedZero :: Speed-speedZero = Speed 0---- | Normal speed (2 m/s) that suffices to move one tile in one turn.-speedNormal :: Speed-speedNormal = Speed $ 2 * sInMs---- | Scale speed by an @Int@ scalar value.-speedScale :: Rational -> Speed -> Speed-speedScale s (Speed v) = Speed (round $ fromIntegral v * s)---- | Speed addition.-speedAdd :: Speed -> Speed -> Speed-speedAdd (Speed s1) (Speed s2) = Speed (s1 + s2)---- | Speed negation.-speedNegate :: Speed -> Speed-speedNegate (Speed n) = Speed (-n)---- | The number of time ticks it takes to walk 1 meter at the given speed.-ticksPerMeter :: Speed -> Delta Time-ticksPerMeter (Speed v) = Delta $ Time $ _ticksInSecond * sInMs `divUp` max 1 v---- | Calculate projectile speed from item weight in grams--- and velocity percent modifier.--- See <https://github.com/LambdaHack/LambdaHack/wiki/Item-statistics>.-speedFromWeight :: Int -> Int -> Speed-speedFromWeight weight velocityPercent =-  let w = fromIntegral weight-      vp = fromIntegral velocityPercent-      mpMs | w <= 500 = sInMs * 16-           | w > 500 && w <= 2000 = sInMs * 16 * 1500 `div` (w + 1000)-           | w < 16000 = sInMs * (18000 - w) `div` 1000-           | w < 200000 = sInMs  -- half a step per turn is the minimum-           | otherwise = 0  -- unless _very_ heavy-               -- TODO: such high weight should also affect moving-      v = mpMs * vp `div` 100-      -- We round down to the nearest multiple of 2M (unless the speed-      -- is very low), to ensure both turns of flight cover the same distance-      -- and that the speed matches the distance traveled exactly.-      multiple2M = sInMs * if v > 2 * sInMs-                           then 2 * (v `div` (2 * sInMs))-                           else v `div` sInMs-      minimumSpeed = if mpMs == 0 then 0 else sInMs-  in Speed $ max minimumSpeed multiple2M---- | Calculate maximum range in meters of a projectile from its speed.--- See <https://github.com/LambdaHack/LambdaHack/wiki/Item-statistics>.--- With this formula, each projectile flies for at most 1 second,--- that is 2 turns, and then drops to the ground.-rangeFromSpeed :: Speed -> Int-rangeFromSpeed (Speed v) = fromIntegral $ v `div` sInMs---- | Calculate maximum range taking into account the linger percentage.-rangeFromSpeedAndLinger :: Speed -> Int -> Int-rangeFromSpeedAndLinger speed linger =-  let range = rangeFromSpeed speed-  in linger * range `div` 100
− Game/LambdaHack/Common/Vector.hs 
@@ -1,224 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Basic operations on 2D vectors represented in an efficient,--- but not unique, way.-module Game.LambdaHack.Common.Vector-  ( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector-  , moves, movesCardinal, movesDiagonal, compassText, vicinity, vicinityCardinal-  , shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded-  , vectorToFrom, pathToTrajectory-  , RadianAngle, rotate, towards-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import Data.Int (Int32)-import Data.Maybe-import Data.Text (Text)--import Game.LambdaHack.Common.Point---- | 2D vectors in cartesian representation. Coordinates grow to the right--- and down, so that the (1, 1) vector points to the bottom-right corner--- of the screen.-data Vector = Vector-  { vx :: !X-  , vy :: !Y-  }-  deriving (Eq, Ord, Show, Read)--instance Binary Vector where-  put = put . (fromIntegral :: Int -> Int32) . fromEnum-  get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get--instance Enum Vector where-  fromEnum = fromEnumVector-  toEnum = toEnumVector---- | Maximal supported vector X and Y coordinates.-maxVectorDim :: Int-{-# INLINE maxVectorDim #-}-maxVectorDim = 2 ^ (maxLevelDimExponent - 1) - 1--fromEnumVector :: Vector -> Int-{-# INLINE fromEnumVector #-}-fromEnumVector (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent)--toEnumVector :: Int -> Vector-{-# INLINE toEnumVector #-}-toEnumVector n =-  let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent)-      (vx, vy) = if x > maxVectorDim-                 then (x - 2 ^ maxLevelDimExponent, y + 1)-                 else if x < - maxVectorDim-                      then (x + 2 ^ maxLevelDimExponent, y - 1)-                      else (x, y)-  in Vector{..}---- | Tells if a vector has length 1 in the chessboard metric.-isUnit :: Vector -> Bool-{-# INLINE isUnit #-}-isUnit v = chessDistVector v == 1---- | Checks whether a unit vector is a diagonal direction,--- as opposed to cardinal. If the vector is not unit,--- it checks that the vector is not horizontal nor vertical.-isDiagonal :: Vector -> Bool-{-# INLINE isDiagonal #-}-isDiagonal (Vector x y) = x * y /= 0---- | Reverse an arbirary vector.-neg :: Vector -> Vector-{-# INLINE neg #-}-neg (Vector vx vy) = Vector (-vx) (-vy)---- | Squared euclidean distance between two vectors.-euclidDistSqVector :: Vector -> Vector -> Int-{-# INLINE euclidDistSqVector #-}-euclidDistSqVector (Vector x0 y0) (Vector x1 y1) =-  let square n = n ^ (2 :: Int)-  in square (x1 - x0) + square (y1 - y0)---- | The lenght of a vector in the chessboard metric,--- where diagonal moves cost 1.-chessDistVector :: Vector -> Int-{-# INLINE chessDistVector #-}-chessDistVector (Vector x y) = max (abs x) (abs y)---- | Vectors of all unit moves in the chessboard metric,--- clockwise, starting north-west.-moves :: [Vector]-moves =-  map (uncurry Vector)-    [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]--moveTexts :: [Text]-moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"]--compassText :: Vector -> Text-compassText v = let m = EM.fromList $ zip moves moveTexts-                in fromMaybe (assert `failure` "not a unit vector"-                                     `twith` v) $ EM.lookup v m---- | Vectors of all cardinal direction unit moves, clockwise, starting north.-movesCardinal :: [Vector]-movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)]---- | Vectors of all diagonal direction unit moves, clockwise, starting north.-movesDiagonal :: [Vector]-movesDiagonal = map (uncurry Vector) [(-1, -1), (1, -1), (1, 1), (-1, 1)]---- | All (8 at most) closest neighbours of a point within an area.-vicinity :: X -> Y   -- ^ limit the search to this area-         -> Point    -- ^ position to find neighbours of-         -> [Point]-vicinity lxsize lysize p =-  [ res | dxy <- moves-        , let res = shift p dxy-        , inside res (0, 0, lxsize - 1, lysize - 1) ]---- | All (4 at most) cardinal direction neighbours of a point within an area.-vicinityCardinal :: X -> Y   -- ^ limit the search to this area-                 -> Point    -- ^ position to find neighbours of-                 -> [Point]-vicinityCardinal lxsize lysize p =-  [ res | dxy <- movesCardinal-        , let res = shift p dxy-        , inside res (0, 0, lxsize - 1, lysize - 1) ]---- | Translate a point by a vector.-shift :: Point -> Vector -> Point-{-# INLINE shift #-}-shift (Point x0 y0) (Vector x1 y1) = Point (x0 + x1) (y0 + y1)---- | Translate a point by a vector, but only if the result fits in an area.-shiftBounded :: X -> Y -> Point -> Vector -> Point-shiftBounded lxsize lysize pos v@(Vector xv yv) =-  if inside pos (-xv, -yv, lxsize - xv - 1, lysize - yv - 1)-  then shift pos v-  else pos---- | A list of points that a list of vectors leads to.-trajectoryToPath :: Point -> [Vector] -> [Point]-trajectoryToPath _ [] = []-trajectoryToPath start (v : vs) = let next = shift start v-                                  in next : trajectoryToPath next vs---- | A list of points that a list of vectors leads to, bounded by level size.-trajectoryToPathBounded :: X -> Y -> Point -> [Vector] -> [Point]-trajectoryToPathBounded _ _ _ [] = []-trajectoryToPathBounded lxsize lysize start (v : vs) =-  let next = shiftBounded lxsize lysize start v-  in next : trajectoryToPathBounded lxsize lysize next vs---- | The vector between the second point and the first. We have------ > shift pos1 (pos2 `vectorToFrom` pos1) == pos2------ The arguments are in the same order as in the underlying scalar subtraction.-vectorToFrom :: Point -> Point -> Vector-{-# INLINE vectorToFrom #-}-vectorToFrom (Point x0 y0) (Point x1 y1) = Vector (x0 - x1) (y0 - y1)---- | A list of vectors between a list of points.-pathToTrajectory :: [Point] -> [Vector]-pathToTrajectory [] = []-pathToTrajectory lp1@(_ : lp2) = zipWith vectorToFrom lp2 lp1-type RadianAngle = Double---- | Rotate a vector by the given angle (expressed in radians)--- counterclockwise and return a unit vector approximately in the resulting--- direction.-rotate :: RadianAngle -> Vector -> Vector-rotate angle (Vector x' y') =-  let x = fromIntegral x'-      y = fromIntegral y'-      -- Minus before the angle comes from our coordinates being-      -- mirrored along the X axis (Y coordinates grow going downwards).-      dx = x * cos (-angle) - y * sin (-angle)-      dy = x * sin (-angle) + y * cos (-angle)-  in normalize dx dy---- TODO: use bla for that--- | Given a vector of arbitrary non-zero length, produce a unit vector--- that points in the same direction (in the chessboard metric).--- Of several equally good directions it picks one of those that visually--- (in the euclidean metric) maximally align with the original vector.-normalize :: Double -> Double -> Vector-normalize dx dy =-  assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `twith` (dx, dy)) $-  let angle :: Double-      angle = atan (dy / dx) / (pi / 2)-      dxy | angle <= -0.75 && angle >= -1.25 = (0, -1)-          | angle <= -0.25 = (1, -1)-          | angle <= 0.25  = (1, 0)-          | angle <= 0.75  = (1, 1)-          | angle <= 1.25  = (0, 1)-          | otherwise = assert `failure` "impossible angle"-                               `twith` (dx, dy, angle)-  in if dx >= 0-     then uncurry Vector dxy-     else neg $ uncurry Vector dxy--normalizeVector :: Vector -> Vector-normalizeVector v@(Vector vx vy) =-  let res = normalize (fromIntegral vx) (fromIntegral vy)-  in assert (not (isUnit v) || v == res-             `blame` "unit vector gets untrivially normalized"-             `twith` (v, res))-     res---- TODO: Perhaps produce all acceptable directions and let AI choose.--- That would also eliminate the Doubles. Or only directions from bla?--- Smart monster could really use all dirs to be less predictable,--- but it wouldn't look as natural as bla, so for less smart bla is better.--- | Given two distinct positions, determine the direction (a unit vector)--- in which one should move from the first in order to get closer--- to the second. Ignores obstacles. Of several equally good directions--- (in the chessboard metric) it picks one of those that visually--- (in the euclidean metric) maximally align with the vector between--- the two points.-towards :: Point -> Point -> Vector-towards pos0 pos1 =-  assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1))-  $ normalizeVector $ pos1 `vectorToFrom` pos0
− Game/LambdaHack/Content/CaveKind.hs 
@@ -1,75 +0,0 @@--- | The type of cave layout kinds.-module Game.LambdaHack.Content.CaveKind-  ( CaveKind(..), validateCaveKind-  ) where--import Data.Text (Text)-import qualified Data.Text as T--import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random---- | Parameters for the generation of dungeon levels.-data CaveKind = CaveKind-  { csymbol         :: !Char         -- ^ a symbol-  , cname           :: !Text         -- ^ short description-  , cfreq           :: !Freqs        -- ^ frequency within groups-  , cxsize          :: !X            -- ^ X size of the whole cave-  , cysize          :: !Y            -- ^ Y size of the whole cave-  , cgrid           :: !Dice.DiceXY  -- ^ the dimensions of the grid of places-  , cminPlaceSize   :: !Dice.DiceXY  -- ^ minimal size of places-  , cmaxPlaceSize   :: !Dice.DiceXY  -- ^ maximal size of places-  , cdarkChance     :: !Dice.Dice    -- ^ the chance a place is dark-  , cnightChance    :: !Dice.Dice    -- ^ the chance the cave is dark-  , cauxConnects    :: !Rational     -- ^ a proportion of extra connections-  , cmaxVoid        :: !Rational     -- ^ at most this proportion of rooms void-  , cminStairDist   :: !Int          -- ^ minimal distance between stairs-  , cdoorChance     :: !Chance       -- ^ the chance of a door in an opening-  , copenChance     :: !Chance       -- ^ if there's a door, is it open?-  , chidden         :: !Int          -- ^ if not open, hidden one in n times-  , cactorFreq      :: !Freqs        -- ^ actor groups to consider-  , citemNum        :: !Dice.Dice    -- ^ the number of items in the cave-  , citemFreq       :: !Freqs        -- ^ item groups to consider-  , cplaceFreq      :: !Freqs        -- ^ place groups to consider-  , cpassable       :: !Bool         -- ^ are passable default tiles permitted-  , cdefTile        :: !Text         -- ^ the default cave tile group name-  , cdarkCorTile    :: !Text         -- ^ the dark cave corridor tile group name-  , clitCorTile     :: !Text         -- ^ the lit cave corridor tile group name-  , cfillerTile     :: !Text         -- ^ the filler wall group name-  , couterFenceTile :: !Text         -- ^ the outer fence wall group name-  , clegendDarkTile :: !Text         -- ^ the dark place plan legend group name-  , clegendLitTile  :: !Text         -- ^ the lit place plan legend group name-  }-  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53---- TODO: check many things, e.g., if all items and actors fit in the dungeon.--- | Filter a list of kinds, passing through only the incorrect ones, if any.------ Catch caves with not enough space for all the places. Check the size--- of the cave descriptions to make sure they fit on screen.-validateCaveKind :: [CaveKind] -> [CaveKind]-validateCaveKind = filter (\CaveKind{..} ->-  let (maxGridX, maxGridY) = Dice.maxDiceXY cgrid-      (minMinSizeX, minMinSizeY) = Dice.minDiceXY cminPlaceSize-      (maxMinSizeX, maxMinSizeY) = Dice.maxDiceXY cminPlaceSize-      (minMaxSizeX, minMaxSizeY) = Dice.minDiceXY cmaxPlaceSize-      -- If there is at most one room, we need extra borders for a passage,-      -- but if there may be more rooms, we have that space, anyway,-      -- because multiple rooms take more space than borders.-      xborder = if maxGridX == 1 || couterFenceTile /= "basic outer fence"-                then 2-                else 0-      yborder = if maxGridY == 1 || couterFenceTile /= "basic outer fence"-                then 2-                else 0-  in T.length cname > 25-     || cxsize < 7-     || cysize < 7-     || minMinSizeX < 1-     || minMinSizeY < 1-     || minMaxSizeX < maxMinSizeX-     || minMaxSizeY < maxMinSizeY-     || maxGridX * (maxMinSizeX + 1) + xborder >= cxsize-     || maxGridY * (maxMinSizeY + 1) + yborder >= cysize)
− Game/LambdaHack/Content/FactionKind.hs 
@@ -1,23 +0,0 @@--- | The type of kinds of game factions (heroes, enemies, NPCs, etc.).-module Game.LambdaHack.Content.FactionKind-  ( FactionKind(..), validateFactionKind-  ) where--import Data.Text (Text)-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Misc---- | Faction properties that are fixed for a given kind of factions.-data FactionKind = FactionKind-  { fsymbol       :: !Char    -- ^ a symbol-  , fname         :: !Text    -- ^ short description-  , ffreq         :: !Freqs   -- ^ frequency within groups-  , fSkillsLeader :: !Skills  -- ^ skills of the picked leader-  , fSkillsOther  :: !Skills  -- ^ skills of the other actors-  }-  deriving Show---- | No specific possible problems for the content of this kind, so far,--- so the validation function always returns the empty list of offending kinds.-validateFactionKind :: [FactionKind] -> [FactionKind]-validateFactionKind _ = []
− Game/LambdaHack/Content/ItemKind.hs 
@@ -1,55 +0,0 @@--- | The type of kinds of weapons, treasure, organs, shrapnel and actors.-module Game.LambdaHack.Content.ItemKind-  ( ItemKind(..), toVelocity, toLinger, validateItemKind-  ) where--import Data.Function-import Data.List-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Misc---- | Item properties that are fixed for a given kind of items.-data ItemKind = ItemKind-  { isymbol  :: !Char              -- ^ map symbol-  , iname    :: !Text              -- ^ generic name-  , ifreq    :: !Freqs             -- ^ frequency within groups-  , iflavour :: ![Flavour]         -- ^ possible flavours-  , icount   :: !Dice.Dice         -- ^ created in that quantity-  , irarity  :: ![(Int, Int)]      -- ^ rarity on given depths-  , iverbHit :: !MU.Part           -- ^ the verb for applying and melee-  , iweight  :: !Int               -- ^ weight in grams-  , iaspects :: ![Effect.Aspect Dice.Dice]-                                   -- ^ keep the aspect continuously-  , ieffects :: ![Effect.Effect Dice.Dice]-                                   -- ^ cause the effect when triggered-  , ifeature :: ![Effect.Feature]  -- ^ public properties-  , idesc    :: !Text              -- ^ description-  , ikit     :: ![(Text, CStore)]  -- ^ accompanying organs and items-  }-  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53--toVelocity :: Int -> Effect.Feature-toVelocity n = Effect.ToThrow $ Effect.ThrowMod n 100--toLinger :: Int -> Effect.Feature-toLinger n = Effect.ToThrow $ Effect.ThrowMod 100 n---- | Filter a list of kinds, passing through only the incorrect ones, if any.-validateItemKind :: [ItemKind] -> [ItemKind]-validateItemKind l =-  let bad ik = T.length (iname ik) > 23-               || let sortedRarity = sortBy (comparing fst) (irarity ik)-                  in sortedRarity /= irarity ik-                     || nubBy ((==) `on` fst) sortedRarity /= sortedRarity-                     || case (sortedRarity, reverse sortedRarity) of-                       ((lowest, _) : _, (highest, _) : _) ->-                         lowest < 1 || highest > 10-                       _ -> False-  in filter bad l
− Game/LambdaHack/Content/ModeKind.hs 
@@ -1,84 +0,0 @@--- | The type of kinds of game modes.-module Game.LambdaHack.Content.ModeKind-  ( Caves, Players(..), Player(..), ModeKind(..), validateModeKind-  ) where--import Data.Binary-import qualified Data.IntMap.Strict as IM-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU ()--import Game.LambdaHack.Common.Misc (Freqs)---- | Game mode specification.-data ModeKind = ModeKind-  { msymbol  :: !Char     -- ^ a symbol (matches the keypress, if any)-  , mname    :: !Text     -- ^ short description-  , mfreq    :: !Freqs    -- ^ frequency within groups-  , mplayers :: !Players  -- ^ players taking part in the game-  , mcaves   :: !Caves    -- ^ arena of the game-  , mdesc    :: !Text     -- ^ description-  }-  deriving Show---- | Requested cave groups for particular levels. The default is--- the "dng" group, which means a random choice from all caves--- that can randomly appear. The second component of the pair--- is the @Escape@ feature on the level. @True@ means it's represented--- by @<@, @False@, by @>@.-type Caves = IM.IntMap (Text, Maybe Bool)---- | The specification of players for the game mode.-data Players = Players-  { playersList  :: ![Player]        -- ^ players, both human and computer-  , playersEnemy :: ![(Text, Text)]  -- ^ the initial enmity matrix-  , playersAlly  :: ![(Text, Text)]  -- ^ the initial aliance matrix-  }-  deriving (Show, Eq)---- | Properties of a particular player.-data Player = Player-  { playerName    :: !Text     -- ^ name of the player-  , playerFaction :: !Text     -- ^ name of faction(s) the player can control-  , playerIsSpawn :: !Bool     -- ^ whether the player is a spawn (score, AI)-  , playerIsHero  :: !Bool     -- ^ whether the player is a hero (score, AI, UI)-  , playerEntry   :: !Int      -- ^ level where the initial members start-  , playerInitial :: !Int      -- ^ number of initial members-  , playerLeader  :: !Bool     -- ^ leaderless factions can't be controlled-                               --   by a human or a user-supplied AI client-  , playerAI      :: !Bool     -- ^ is the faction under AI control?-  , playerUI      :: !Bool     -- ^ does the faction have a UI client-                               --   (for control or passive observation)-  }-  deriving (Show, Eq)---- TODO: assert every Player's playerName's first word's length <= 15--- TODO: assert if no UI, both Ai are on and there are some non-spawners;--- assert that playersEnemy and playersAlly mention only factions in play.--- | No specific possible problems for the content of this kind, so far,--- so the validation function always returns the empty list of offending kinds.-validateModeKind :: [ModeKind] -> [ModeKind]-validateModeKind _ = []--instance Binary Player where-  put Player{..} = do-    put playerName-    put playerFaction-    put playerIsSpawn-    put playerIsHero-    put playerEntry-    put playerInitial-    put playerLeader-    put playerAI-    put playerUI-  get = do-    playerName <- get-    playerFaction <- get-    playerIsSpawn <- get-    playerIsHero <- get-    playerEntry <- get-    playerInitial <- get-    playerLeader <- get-    playerAI <- get-    playerUI <- get-    return $! Player{..}
− Game/LambdaHack/Content/PlaceKind.hs 
@@ -1,54 +0,0 @@--- | The type of kinds of rooms, halls and passages.-module Game.LambdaHack.Content.PlaceKind-  ( PlaceKind(..), Cover(..), Fence(..), validatePlaceKind-  ) where--import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Common.Misc---- | Parameters for the generation of small areas within a dungeon level.-data PlaceKind = PlaceKind-  { psymbol   :: !Char      -- ^ a symbol-  , pname     :: !Text      -- ^ short description-  , pfreq     :: !Freqs     -- ^ frequency within groups-  , prarity   :: ![(Int, Int)]  -- ^ rarity on given depths-  , pcover    :: !Cover     -- ^ how to fill whole place based on the corner-  , pfence    :: !Fence     -- ^ whether to fence the place with solid border-  , ptopLeft  :: ![Text]    -- ^ plan of the top-left corner of the place-  , poverride :: ![(Char, Text)]  -- ^ legend override, ignoring tile symbol-  }-  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53---- | A method of filling the whole area (except for CVerbatim, which is just--- placed in the middle of the area), by transforming a given corner.-data Cover =-    CAlternate   -- ^ reflect every other corner, overlapping 1 row and column-  | CStretch     -- ^ fill symmetrically 4 corners and stretch their borders-  | CReflect     -- ^ tile separately and symmetrically quarters of the place-  | CVerbatim    -- ^ just build the given interior, without filling the area-  deriving (Show, Eq)---- | The choice of a fence type for the place.-data Fence =-    FWall   -- ^ put a solid wall fence around the place-  | FFloor  -- ^ leave an empty floor space around the place-  | FNone   -- ^ skip the fence and fill all with the place proper-  deriving (Show, Eq)---- TODO: Verify that places are fully accessible from any entrace on the fence--- that is at least 4 tiles distant from the edges, if the place is big enough,--- (unless the place has FNone fence, in which case the entrance is--- at the outer tiles of the place).--- TODO: Check that all symbols in place plans are present in the legend.--- TODO: Add a field with tile group to be used as the legend.--- | Filter a list of kinds, passing through only the incorrect ones, if any.------ Verify that the top-left corner map is rectangular and not empty.-validatePlaceKind :: [PlaceKind] -> [PlaceKind]-validatePlaceKind = filter (\ PlaceKind{..} ->-  let dxcorner = case ptopLeft of-        [] -> 0-        l : _ -> T.length l-  in dxcorner /= 0 && any (/= dxcorner) (map T.length ptopLeft))
− Game/LambdaHack/Content/RuleKind.hs 
@@ -1,85 +0,0 @@--- | The type of game rule sets and assorted game data.-module Game.LambdaHack.Content.RuleKind-  ( RuleKind(..), validateRuleKind, FovMode(..)-  ) where--import Data.Binary-import Data.Text (Text)-import Data.Version--import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point---- TODO: very few rules are configurable yet, extend as needed.--- TODO: in the future, in @raccessible@ check flying for chasms,--- swimming for water, etc.--- TODO: tweak other code to allow games with only cardinal direction moves---- | The type of game rule sets and assorted game data.------ For now the rules are immutable througout the game, so there is--- no type @Rule@ to hold any changing parameters, just @RuleKind@--- for the fixed set.--- However, in the future, if the rules can get changed during gameplay--- based on data mining of player behaviour, we may add such a type--- and then @RuleKind@ will become just a starting template, analogously--- as for the other content.------ The @raccessible@ field hold extra conditions that have to be met--- for a tile to be accessible, on top of being an open tile--- (or openable, in some contexts). The @raccessibleDoor@ field--- contains yet additional conditions concerning tiles that are doors,--- whether open or closed.--- Precondition: the two positions are next to each other.--- We assume the predicate is symmetric.-data RuleKind = RuleKind-  { rsymbol         :: !Char      -- ^ a symbol-  , rname           :: !Text      -- ^ short description-  , rfreq           :: !Freqs     -- ^ frequency within groups-  , raccessible     :: !(Maybe (Point -> Point -> Bool))-  , raccessibleDoor :: !(Maybe (Point -> Point -> Bool))-  , rtitle          :: !Text      -- ^ the title of the game-  , rpathsDataFile  :: FilePath -> IO FilePath-                                   -- ^ the path to data files-  , rpathsVersion   :: !Version   -- ^ the version of the game-  , rcfgUIName      :: !FilePath  -- ^ base name of the UI config file-  , rcfgUIDefault   :: !String    -- ^ the default UI settings config file-  , rmainMenuArt    :: !Text      -- ^ the ASCII art for the Main Menu-  , rfirstDeathEnds :: !Bool      -- ^ whether first non-spawner actor death-                                   --   ends the game-  , rfovMode        :: !FovMode   -- ^ FOV calculation mode-  , rsaveBkpClips   :: !Int       -- ^ game backup is saved that often-  , rleadLevelClips :: !Int       -- ^ flip AI/spawn leader level that often-  , rscoresFile     :: !FilePath  -- ^ name of the scores file-  , rsavePrefix     :: !String    -- ^ name of the savefile prefix-  , rsharedStash    :: !Bool      -- ^ whether shared stashes are available-  }---- | Field Of View scanning mode.-data FovMode =-    Shadow      -- ^ restrictive shadow casting-  | Permissive  -- ^ permissive FOV-  | Digital     -- ^ digital FOV-  deriving (Show, Read)---- | A dummy instance of the 'Show' class, to satisfy general requirments--- about content. We won't have many rule sets and they contain functions,--- so defining a proper instance is not practical.-instance Show RuleKind where-  show _ = "The game ruleset specification."---- | Validates the ASCII art format (TODO).-validateRuleKind :: [RuleKind] -> [RuleKind]-validateRuleKind _ = []--instance Binary FovMode where-  put Shadow      = putWord8 0-  put Permissive  = putWord8 1-  put Digital     = putWord8 2-  get = do-    tag <- getWord8-    case tag of-      0 -> return Shadow-      1 -> return Permissive-      2 -> return Digital-      _ -> fail "no parse (FovMode)"
− Game/LambdaHack/Content/TileKind.hs 
@@ -1,87 +0,0 @@--- | The type of kinds of terrain tiles.-module Game.LambdaHack.Content.TileKind-  ( TileKind(..), validateTileKind, actionFeatures-  ) where--import Control.Exception.Assert.Sugar-import Data.Hashable (hash)-import qualified Data.IntSet as IS-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Text (Text)--import Game.LambdaHack.Common.Color-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Misc---- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation--- of the absence of a corresponding type @Tile@ that would hold--- particular concrete tiles in the dungeon.-data TileKind = TileKind-  { tsymbol  :: !Char         -- ^ map symbol-  , tname    :: !Text         -- ^ short description-  , tfreq    :: !Freqs        -- ^ frequency within groups-  , tcolor   :: !Color        -- ^ map color-  , tcolor2  :: !Color        -- ^ map color when not in FOV-  , tfeature :: ![F.Feature]  -- ^ properties-  }-  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53---- TODO: Make sure only solid tiles have Suspect.--- TODO: check that all posible solid place fences have hidden counterparts.--- TODO: verify that OpenTo, CloseTo and ChangeTo are assigned as specified.--- | Filter a list of kinds, passing through only the incorrect ones, if any.------ If tiles look the same on the map, the description and the substantial--- features should be the same, too. Otherwise, the player has to inspect--- manually all the tiles of that kind, or even experiment with them,--- to see if any is special. This would be tedious. Note that iiles may freely--- differ wrt dungeon generation, AI preferences, etc.-validateTileKind :: [TileKind] -> [TileKind]-validateTileKind lt =-  let listVis f = map (\kt -> ( ( tsymbol kt-                                  , F.Suspect `elem` tfeature kt-                                  , f kt-                                  )-                                , [kt] )) lt-      mapVis :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind]-      mapVis f = M.fromListWith (++) $ listVis f-      namesUnequal [] = assert `failure` "no TileKind content" `twith` lt-      namesUnequal (hd : tl) =-        -- Catch if at least one is different.-        any (/= tname hd) (map tname tl)-        -- TODO: calculate actionFeatures only once for each tile kind-        || any (/= actionFeatures True hd) (map (actionFeatures True) tl)-      confusions f = filter namesUnequal $ M.elems $ mapVis f-  in case confusions tcolor ++ confusions tcolor2 of-    [] -> []-    l : _ -> l---- | Features of tiles that differentiate them substantially from one another.--- By tile content validation condition, this means the player--- can tell such tile apart, and only looking at the map, not tile name.--- So if running uses this function, it won't stop at places that the player--- can't himself tell from other places, and so running does not confer--- any advantages, except UI convenience. Hashes are accurate enough--- for our purpose, given that we use arbitrary heuristics anyway.-actionFeatures :: Bool -> TileKind -> IS.IntSet-actionFeatures markSuspect t =-  let f feat = case feat of-        F.Cause{} -> Just feat-        F.OpenTo{} -> Just $ F.OpenTo ""  -- if needed, remove prefix/suffix-        F.CloseTo{} -> Just $ F.CloseTo ""-        F.ChangeTo{} -> Just $ F.ChangeTo ""-        F.Walkable -> Just feat-        F.Clear -> Just feat-        F.Suspect -> if markSuspect then Just feat else Nothing-        F.Aura{} -> Just feat-        F.Impenetrable -> Just feat-        F.Trail -> Just feat  -- doesn't affect tile behaviour, but important-        F.HideAs{} -> Nothing-        F.RevealAs{} -> Nothing-        F.Dark -> Nothing  -- not important any longer, after FOV computed-        F.OftenItem -> Nothing-        F.OftenActor -> Nothing-        F.NoItem -> Nothing-        F.NoActor -> Nothing-  in IS.fromList $ map hash $ mapMaybe f $ tfeature t
− Game/LambdaHack/SampleImplementation/SampleMonadClient.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses #-}--- | The main game action monad type implementation. Just as any other--- component of the library, this implementation can be substituted.--- This module should not be imported anywhere except in 'Action'--- to expose the executor to any code using the library.-module Game.LambdaHack.SampleImplementation.SampleMonadClient-  ( executorCli-  ) where--import Control.Applicative-import Control.Concurrent.STM-import qualified Control.Monad.IO.Class as IO-import Control.Monad.Trans.State.Strict hiding (State)-import Data.Maybe-import System.FilePath--import Game.LambdaHack.Atomic.HandleAtomicWrite-import Game.LambdaHack.Atomic.MonadAtomic-import Game.LambdaHack.Atomic.MonadStateWrite-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.ProtocolClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.MonadStateRead-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State-import Game.LambdaHack.Server.ProtocolServer--data CliState resp req = CliState-  { cliState   :: !State        -- ^ current global state-  , cliClient  :: !StateClient  -- ^ current client state-  , cliDict    :: !(ChanServer resp req)-                                -- ^ this client connection information-  , cliToSave  :: !(Save.ChanSave (State, StateClient))-                                -- ^ connection to the save thread-  , cliSession :: SessionUI     -- ^ UI setup data, empty for AI clients-  }---- | Server state transformation monad.-newtype CliImplementation resp req a =-    CliImplementation {runCliImplementation :: StateT (CliState resp req) IO a}-  deriving (Monad, Functor, Applicative)--instance MonadStateRead (CliImplementation resp req) where-  getState    = CliImplementation $ gets cliState-  getsState f = CliImplementation $ gets $ f . cliState--instance MonadStateWrite (CliImplementation resp req) where-  modifyState f = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliState = f $ cliState cliS}-    in newCliS `seq` ((), newCliS)-  putState    s = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliState = s}-    in newCliS `seq` ((), newCliS)--instance MonadClient (CliImplementation resp req) where-  getClient      = CliImplementation $ gets cliClient-  getsClient   f = CliImplementation $ gets $ f . cliClient-  modifyClient f = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliClient = f $ cliClient cliS}-    in newCliS `seq` ((), newCliS)-  putClient    s = CliImplementation $ state $ \cliS ->-    let newCliS = cliS {cliClient = s}-    in newCliS `seq` ((), newCliS)-  liftIO         = CliImplementation . IO.liftIO-  saveChanClient = CliImplementation $ gets cliToSave--instance MonadClientUI (CliImplementation resp req) where-  getsSession f  = CliImplementation $ gets $ f . cliSession-  liftIO         = CliImplementation . IO.liftIO--instance MonadClientReadResponse resp (CliImplementation resp req) where-  receiveResponse     = CliImplementation $ do-    ChanServer{responseS} <- gets cliDict-    IO.liftIO $ atomically . readTQueue $ responseS--instance MonadClientWriteRequest req (CliImplementation resp req) where-  sendRequest scmd = CliImplementation $ do-    ChanServer{requestS} <- gets cliDict-    IO.liftIO $ atomically . writeTQueue requestS $ scmd--instance MonadAtomic (CliImplementation resp req) where-  execAtomic = handleCmdAtomic---- | Init the client, then run an action, with a given session,--- state and history, in the @IO@ monad.-executorCli :: CliImplementation resp req ()-            -> SessionUI -> State -> StateClient -> ChanServer resp req-            -> IO ()-executorCli m cliSession cliState cliClient cliDict =-  let saveFile (_, cli2) =-        fromMaybe "save" (ssavePrefixCli (sdebugCli cli2))-        <.> saveName (sside cli2) (sisAI cli2)-      exe cliToSave =-        evalStateT (runCliImplementation m) CliState{..}-  in Save.wrapInSaves saveFile exe
− Game/LambdaHack/SampleImplementation/SampleMonadServer.hs 
@@ -1,102 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | 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.SampleImplementation.SampleMonadServer-  ( executorSer-  ) where--import Control.Applicative-import qualified Control.Monad.IO.Class as IO-import Control.Monad.Trans.State.Strict hiding (State)-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import System.FilePath--import Game.LambdaHack.Atomic.BroadcastAtomicWrite-import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Atomic.MonadAtomic-import Game.LambdaHack.Atomic.MonadStateWrite-import Game.LambdaHack.Common.MonadStateRead-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.ProtocolServer-import Game.LambdaHack.Server.State--data SerState = SerState-  { serState  :: !State           -- ^ current global state-  , serServer :: !StateServer     -- ^ current server state-  , serDict   :: !ConnServerDict  -- ^ client-server connection information-  , serToSave :: !(Save.ChanSave (State, StateServer))-                                  -- ^ connection to the save thread-  }---- | Server state transformation monad.-newtype SerImplementation a =-    SerImplementation {runSerImplementation :: StateT SerState IO a}-  deriving (Monad, Functor, Applicative)--instance MonadStateRead SerImplementation where-  getState    = SerImplementation $ gets serState-  getsState f = SerImplementation $ gets $ f . serState--instance MonadStateWrite SerImplementation where-  modifyState f = SerImplementation $ state $ \serS ->-    let newSerS = serS {serState = f $ serState serS}-    in newSerS `seq` ((), newSerS)-  putState    s = SerImplementation $ state $ \serS ->-    let newSerS = serS {serState = s}-    in newSerS `seq` ((), newSerS)--instance MonadServer SerImplementation where-  getServer      = SerImplementation $ gets serServer-  getsServer   f = SerImplementation $ gets $ f . serServer-  modifyServer f = SerImplementation $ state $ \serS ->-    let newSerS = serS {serServer = f $ serServer serS}-    in newSerS `seq` ((), newSerS)-  putServer    s = SerImplementation $ state $ \serS ->-    let newSerS = serS {serServer = s}-    in newSerS `seq` ((), newSerS)-  liftIO         = SerImplementation . IO.liftIO-  saveChanServer = SerImplementation $ gets serToSave--instance MonadServerReadRequest SerImplementation where-  getDict      = SerImplementation $ gets serDict-  getsDict   f = SerImplementation $ gets $ f . serDict-  modifyDict f =-    SerImplementation $ modify $ \serS -> serS {serDict = f $ serDict serS}-  putDict    s =-    SerImplementation $ modify $ \serS -> serS {serDict = s}-  liftIO       = SerImplementation . IO.liftIO---- | The game-state semantics of atomic game commands--- as computed on the server.-instance MonadAtomic SerImplementation where-  execAtomic = handleAndBroadcastServer---- | Send an atomic action to all clients that can see it.-handleAndBroadcastServer :: (MonadStateWrite m, MonadServerReadRequest m)-                         => CmdAtomic -> m ()-handleAndBroadcastServer atomic = do-  persOld <- getsServer sper-  knowEvents <- getsServer $ sknowEvents . sdebugSer-  handleAndBroadcast knowEvents persOld resetFidPerception resetLitInDungeon-                     sendUpdateAI sendUpdateUI atomic---- | Run an action in the @IO@ monad, with undefined state.-executorSer :: SerImplementation () -> IO ()-executorSer m =-  let saveFile (_, ser) =-        fromMaybe "save" (ssavePrefixSer (sdebugSer ser))-        <.> saveName-      exe serToSave =-        evalStateT (runSerImplementation m)-          SerState { serState = emptyState-                   , serServer = emptyStateServer-                   , serDict = EM.empty-                   , serToSave-                   }-  in Save.wrapInSaves saveFile exe
− Game/LambdaHack/Server.hs 
@@ -1,58 +0,0 @@--- | Semantics of requests that are sent to the server.------ See--- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Server-  ( mainSer-  ) where--import Control.Concurrent-import qualified Control.Exception as Ex hiding (handle)--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.Thread-import Game.LambdaHack.Server.Commandline-import Game.LambdaHack.Server.LoopServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.ProtocolServer-import Game.LambdaHack.Server.State---- | Fire up the frontend with the engine fueled by content.--- The action monad types to be used are determined by the 'exeSer'--- and 'executorCli' calls. If other functions are used in their place--- the types are different and so the whole pattern of computation--- is different. Which of the frontends is run depends on the flags supplied--- when compiling the engine library.-mainSer :: (MonadAtomic m, MonadServerReadRequest m)-        => [String]-        -> Kind.COps-        -> (m () -> IO ())-        -> (Kind.COps -> DebugModeCli-            -> ((FactionId -> ChanServer ResponseUI RequestUI-                 -> IO ())-                -> (FactionId -> ChanServer ResponseAI RequestAI-                    -> IO ())-                -> IO ())-            -> IO ())-        -> IO ()-mainSer args-        !copsSlow  -- evaluate fully to discover errors ASAP and free memory-        exeSer-        exeFront = do-  sdebugNxt <- debugArgs args-  let cops = speedupCOps False copsSlow-      exeServer executorUI executorAI = do-        -- Wait for clients to exit even in case of server crash-        -- (or server and client crash), which gives them time to save.-        -- TODO: send them a message to tell users "server crashed"-        -- and then let them exit.-        Ex.finally-          (exeSer (loopSer sdebugNxt executorUI executorAI cops))-          (threadDelay 100000)  -- server crashed, show the error eventually-        waitForChildren childrenServer  -- no crash, wait indefinitely-  exeFront cops (sdebugCli sdebugNxt) exeServer
− Game/LambdaHack/Server/Commandline.hs 
@@ -1,117 +0,0 @@--- | Parsing of commandline arguments.-module Game.LambdaHack.Server.Commandline-  ( debugArgs-  ) where--import qualified Data.Text as T--import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Server.State---- TODO: make more maintainable--debugArgs :: [String] -> IO DebugModeSer-debugArgs args = do-  let usage =-        [ "Configure debug options here, gameplay options in config.rules.ini."-        , "  --knowMap  reveal map for all clients in the next game"-        , "  --knowEvents  show all events in the next game (needs --knowMap)"-        , "  --sniffIn  display all incoming commands on console "-        , "  --sniffOut  display all outgoing commands on console "-        , "  --allClear  let all map tiles be translucent"-        , "  --gameMode m  start next game in the given mode"-        , "  --automateAll  give control of all UI teams to computer"-        , "  --newGame  start a new game, overwriting the save file"-        , "  --difficulty n  set difficulty for all UI players to n"-        , "  --stopAfter n  exit this game session after around n seconds"-        , "  --benchmark  print stats, limit saving and other file operations"-        , "  --setDungeonRng s  set dungeon generation RNG seed to string s"-        , "  --setMainRng s  set the main game RNG seed to string s"-        , "  --dumpInitRngs  dump RNG states from the start of the game"-        , "  --dbgMsgSer  let the server emit its internal debug messages"-        , "  --font fn  use the given font for the main game window"-        , "  --maxFps n  display at most n frames per second"-        , "  --noDelay  don't maintain any requested delays between frames"-        , "  --noMore  auto-answer all prompts"-        , "  --noAnim  don't show any animations"-        , "  --savePrefix  prepend the text to all savefile names"-        , "  --frontendStd  use the simple stdout/stdin frontend"-        , "  --frontendNull  use no frontend at all (for AIvsAI benchmarks)"-        , "  --dbgMsgCli  let clients emit their internal debug messages"-        , "  --fovMode m  set a Field of View mode, where m can be"-        , "    Digital"-        , "    Permissive"-        , "    Shadow"-        , "    Blind"-        ]-      parseArgs [] = defDebugModeSer-      parseArgs ("--knowMap" : rest) =-        (parseArgs rest) {sknowMap = True}-      parseArgs ("--knowEvents" : rest) =-        (parseArgs rest) {sknowEvents = True}-      parseArgs ("--sniffIn" : rest) =-        (parseArgs rest) {sniffIn = True}-      parseArgs ("--sniffOut" : rest) =-        (parseArgs rest) {sniffOut = True}-      parseArgs ("--allClear" : rest) =-        (parseArgs rest) {sallClear = True}-      parseArgs ("--gameMode" : s : rest) =-        (parseArgs rest) {sgameMode = T.pack s}-      parseArgs ("--automateAll" : rest) =-        (parseArgs rest) {sautomateAll = True}-      parseArgs ("--newGame" : rest) =-        let debugSer = parseArgs rest-        in debugSer { snewGameSer = True-                    , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}}-      parseArgs ("--difficulty" : s : rest) =-        let debugSer = parseArgs rest-            diff = read s-        in debugSer { sdifficultySer = diff-                    , sdebugCli = (sdebugCli debugSer) {sdifficultyCli = diff}}-      parseArgs ("--stopAfter" : s : rest) =-        (parseArgs rest) {sstopAfter = Just $ read s}-      parseArgs ("--benchmark" : rest) =-        (parseArgs rest) {sbenchmark = True}-      parseArgs ("--setDungeonRng" : s : rest) =-        (parseArgs rest) {sdungeonRng = Just $ read s}-      parseArgs ("--setMainRng" : s : rest) =-        (parseArgs rest) {smainRng = Just $ read s}-      parseArgs ("--dumpInitRngs" : rest) =-        (parseArgs rest) {sdumpInitRngs = True}-      parseArgs ("--fovMode" : mode : rest) =-        (parseArgs rest) {sfovMode = Just $ read mode}-      parseArgs ("--dbgMsgSer" : rest) =-        (parseArgs rest) {sdbgMsgSer = True}-      parseArgs ("--font" : s : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfont = Just s}}-      parseArgs ("--maxFps" : n : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli =-                       (sdebugCli debugSer) {smaxFps = Just $ max 1 $ read n}}-      parseArgs ("--noDelay" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {snoDelay = True}}-      parseArgs ("--noMore" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {snoMore = True}}-      parseArgs ("--noAnim" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {snoAnim = Just True}}-      parseArgs ("--savePrefix" : s : rest) =-        let debugSer = parseArgs rest-        in debugSer { ssavePrefixSer = Just s-                    , sdebugCli =-                        (sdebugCli debugSer) {ssavePrefixCli = Just s}}-      parseArgs ("--frontendStd" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendStd = True}}-      parseArgs ("--frontendNull" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendNull = True}}-      parseArgs ("--dbgMsgCli" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}}-      parseArgs (wrong : _rest) =-        error $ "Unrecognized: " ++ wrong ++ "\n" ++ unlines usage-  return $! parseArgs args
− Game/LambdaHack/Server/CommonServer.hs 
@@ -1,405 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Server operations common to many modules.-module Game.LambdaHack.Server.CommonServer-  ( execFailure, resetFidPerception, resetLitInDungeon, getPerFid-  , revealItems, moveStores, deduceQuits, deduceKilled, electLeader-  , addActor, addActorIid, projectFail, pickWeaponServer, sumOrganEqpServer-  , actorSkillsServer-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Int (Int64)-import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State--execFailure :: (MonadAtomic m, MonadServer m)-            => ActorId -> RequestTimed a -> ReqFailure -> m ()-execFailure aid req failureSer = do-  -- Clients should rarely do that (only in case of invisible actors)-  -- so we report it, send a --more-- meeesage (if not AI), but do not crash-  -- (server should work OK with stupid clients, too).-  body <- getsState $ getActorBody aid-  let fid = bfid body-      msg = showReqFailure failureSer-  debugPrint $ "execFailure:" <+> msg <> "\n"-               <> tshow body <> "\n" <> tshow req-  execSfxAtomic $ SfxMsgFid fid $ "Unexpected problem:" <+> msg <> "."-    -- TODO: --more--, but keep in history---- | Update the cached perception for the selected level, for a faction.--- The assumption is the level, and only the level, has changed since--- the previous perception calculation.-resetFidPerception :: MonadServer m-                   => PersLit -> FactionId -> LevelId-                   -> m Perception-resetFidPerception persLit fid lid = do-  cops <- getsState scops-  sfovMode <- getsServer $ sfovMode . sdebugSer-  lvl <- getLevel lid-  let fovMode = fromMaybe Digital sfovMode-      per = fidLidPerception cops fovMode persLit fid lid lvl-      upd = EM.adjust (EM.adjust (const per) lid) fid-  modifyServer $ \ser2 -> ser2 {sper = upd (sper ser2)}-  return $! per--resetLitInDungeon :: MonadServer m => m PersLit-resetLitInDungeon = do-  sfovMode <- getsServer $ sfovMode . sdebugSer-  ser <- getServer-  let fovMode = fromMaybe Digital sfovMode-  getsState $ \s -> litInDungeon fovMode s ser--getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception-getPerFid fid lid = do-  pers <- getsServer sper-  let fper = fromMaybe (assert `failure` "no perception for faction"-                               `twith` (lid, fid)) $ EM.lookup fid pers-      per = fromMaybe (assert `failure` "no perception for level"-                              `twith` (lid, fid)) $ EM.lookup lid fper-  return $! per--revealItems :: (MonadAtomic m, MonadServer m)-            => Maybe FactionId -> Maybe Actor -> m ()-revealItems mfid mbody = do-  itemToF <- itemToFullServer-  dungeon <- getsState sdungeon-  let discover b iid k =-        let itemFull = itemToF iid k-        in case itemDisco itemFull of-          Just ItemDisco{itemKindId} -> do-            seed <- getsServer $ (EM.! iid) . sitemSeedD-            execUpdAtomic $ UpdDiscover (blid b) (bpos b) iid itemKindId seed-          _ -> assert `failure` (mfid, mbody, iid, itemFull)-      f aid = do-        b <- getsState $ getActorBody aid-        let ourSide = maybe True (== bfid b) mfid-        when (ourSide && Just b /= mbody) $ mapActorItems_ (discover b) b-  mapDungeonActors_ f dungeon-  maybe skip (\b -> mapActorItems_ (discover b) b) mbody--moveStores :: (MonadAtomic m, MonadServer m)-           => ActorId -> CStore -> CStore -> m ()-moveStores aid fromStore toStore = do-  b <- getsState $ getActorBody aid-  let g iid k = execUpdAtomic $ UpdMoveItem iid k aid fromStore toStore-  mapActorCStore_ fromStore g b--quitF :: (MonadAtomic m, MonadServer m)-      => Maybe Actor -> Status -> FactionId -> m ()-quitF mbody status fid = do-  assert (maybe True ((fid ==) . bfid) mbody) skip-  fact <- getsState $ (EM.! fid) . sfactionD-  let oldSt = gquit fact-  case fmap stOutcome $ oldSt of-    Just Killed -> return ()    -- Do not overwrite in case-    Just Defeated -> return ()  -- many things happen in 1 turn.-    Just Conquer -> return ()-    Just Escape -> return ()-    _ -> do-      when (playerUI $ gplayer fact) $ do-        revealItems (Just fid) mbody-        registerScore status mbody fid-      execUpdAtomic $ UpdQuitFaction fid mbody oldSt $ Just status-      modifyServer $ \ser -> ser {squit = True}  -- end turn ASAP---- Send any QuitFactionA actions that can be deduced from their current state.-deduceQuits :: (MonadAtomic m, MonadServer m) => Actor -> Status -> m ()-deduceQuits body status@Status{stOutcome}-  | stOutcome `elem` [Defeated, Camping, Restart, Conquer] =-    assert `failure` "no quitting to deduce" `twith` (status, body)-deduceQuits body status = do-  let fid = bfid body-      mapQuitF statusF fids = mapM_ (quitF Nothing statusF) $ delete fid fids-  quitF (Just body) status fid-  let inGameOutcome (_, fact) = case fmap stOutcome $ gquit fact of-        Just Killed -> False-        Just Defeated -> False-        Just Restart -> False  -- effectively, commits suicide-        _ -> True-      inGame (fid2, fact2) =-        if inGameOutcome (fid2, fact2)-        then anyActorsAlive fid2-        else return False-  factionD <- getsState sfactionD-  assocsInGame <- filterM inGame $ EM.assocs factionD-  let assocsInGameOutcome = filter inGameOutcome $ EM.assocs factionD-      keysInGame = map fst assocsInGameOutcome-      assocsKeepArena = filter (keepArenaFact . snd) assocsInGame-      assocsUI = filter (playerUI . gplayer . snd) assocsInGame-      worldPeace =-        all (\(fid1, _) -> all (\(_, fact2) -> not $ isAtWar fact2 fid1)-                           assocsInGame)-        assocsInGame-  case assocsKeepArena of-    _ | null assocsUI ->-      -- Only non-UI players left in the game and they all win.-      mapQuitF status{stOutcome=Conquer} keysInGame-    [] ->-      -- Only leaderless and spawners remain (the latter may sometimes-      -- have no leader, just as the former), so they win,-      -- or we could end up in a state with no active arena.-      mapQuitF status{stOutcome=Conquer} keysInGame-    _ | worldPeace ->-      -- Nobody is at war any more, so all win (e.g., horrors, but never mind).-      mapQuitF status{stOutcome=Conquer} keysInGame-    _ | stOutcome status == Escape -> do-      -- Otherwise, in a game with many warring teams alive,-      -- only complete Victory matters, until enough of them die.-      let (victors, losers) = partition (flip isAllied fid . snd)-                              assocsInGameOutcome-      mapQuitF status{stOutcome=Escape} $ map fst victors-      mapQuitF status{stOutcome=Defeated} $ map fst losers-    _ -> return ()--deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m ()-deduceKilled body = do-  Kind.COps{corule} <- getsState scops-  let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule-      fid = bfid body-  fact <- getsState $ (EM.! fid) . sfactionD-  unless (isSpawnFact fact) $ do  -- spawners never die off-    actorsAlive <- anyActorsAlive fid-    when (not actorsAlive || firstDeathEnds) $-      deduceQuits body $ Status Killed (fromEnum $ blid body) ""--anyActorsAlive :: MonadServer m => FactionId -> m Bool-anyActorsAlive fid = do-  fact <- getsState $ (EM.! fid) . sfactionD-  if playerLeader (gplayer fact)-    then return $! isJust $ gleader fact-    else do-      as <- getsState $ fidActorNotProjList fid-      return $! not $ null as--electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()-electLeader fid lid aidDead = do-  mleader <- getsState $ gleader . (EM.! fid) . sfactionD-  when (isNothing mleader || mleader == Just aidDead) $ do-    actorD <- getsState sactorD-    let ours (_, b) = bfid b == fid && not (bproj b)-        party = filter ours $ EM.assocs actorD-    onLevel <- getsState $ actorRegularAssocs (== fid) lid-    let mleaderNew = listToMaybe $ filter (/= aidDead)-                     $ map fst $ onLevel ++ party-    unless (mleader == mleaderNew) $-      execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew--projectFail :: (MonadAtomic m, MonadServer m)-            => ActorId    -- ^ actor projecting the item (is on current lvl)-            -> Point      -- ^ target position of the projectile-            -> Int        -- ^ digital line parameter-            -> ItemId     -- ^ the item to be projected-            -> CStore     -- ^ whether the items comes from floor or inventory-            -> Bool       -- ^ whether the item is a shrapnel-            -> m (Maybe ReqFailure)-projectFail source tpxy eps iid cstore isShrapnel = do-  Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-      spos = bpos sb-  lvl@Level{lxsize, lysize} <- getLevel lid-  case bla lxsize lysize eps spos tpxy of-    Nothing -> return $ Just ProjectAimOnself-    Just [] -> assert `failure` "projecting from the edge of level"-                      `twith` (spos, tpxy)-    Just (pos : restUnlimited) -> do-      item <- getsState $ getItemBody iid-      let fragile = Effect.Fragile `elem` jfeature item-          rest = if fragile-                 then take (chessDist spos tpxy - 1) restUnlimited-                 else restUnlimited-          t = lvl `at` pos-      if not $ Tile.isWalkable cotile t-        then return $ Just ProjectBlockTerrain-        else do-          mab <- getsState $ posToActor pos lid-          actorBlind <- radiusBlind-                        <$> sumOrganEqpServer Effect.EqpSlotAddSight source-          if not $ maybe True (bproj . snd . fst) mab-            then if isShrapnel && bproj sb then do-                   -- Hit the blocking actor.-                   projectBla source spos (pos:rest) iid cstore isShrapnel-                   return Nothing-                 else return $ Just ProjectBlockActor-            else if actorBlind && not (isShrapnel || bproj sb) then-                   return $ Just ProjectBlind-                 else do-                   if isShrapnel && bproj sb && eps `mod` 2 == 0 then-                     -- Make the explosion a bit less regular.-                     projectBla source spos (pos:rest) iid cstore isShrapnel-                   else-                     projectBla source pos rest iid cstore isShrapnel-                   return Nothing--projectBla :: (MonadAtomic m, MonadServer m)-           => ActorId    -- ^ actor projecting the item (is on current lvl)-           -> Point      -- ^ starting point of the projectile-           -> [Point]    -- ^ rest of the trajectory of the projectile-           -> ItemId     -- ^ the item to be projected-           -> CStore     -- ^ whether the items comes from floor or inventory-           -> Bool       -- ^ whether the item is a shrapnel-           -> m ()-projectBla source pos rest iid cstore isShrapnel = do-  sb <- getsState $ getActorBody source-  item <- getsState $ getItemBody iid-  let lid = blid sb-  localTime <- getsState $ getLocalTime lid-  unless isShrapnel $ execSfxAtomic $ SfxProject source iid-  addProjectile pos rest iid lid (bfid sb) localTime isShrapnel-  let c = CActor source cstore-  execUpdAtomic $ UpdLoseItem iid item 1 c---- | Create a projectile actor containing the given missile.------ Projectile has no organs except for the trunk.-addProjectile :: (MonadAtomic m, MonadServer m)-              => Point -> [Point] -> ItemId -> LevelId -> FactionId-              -> Time -> Bool-              -> m ()-addProjectile bpos rest iid blid bfid btime isShrapnel = do-  itemToF <- itemToFullServer-  let itemFull@ItemFull{itemBase} = itemToF iid 1-      (trajectory, (speed, trange)) = itemTrajectory itemBase (bpos : rest)-      adj | trange < 5 = "falling"-          | otherwise = "flying"-      -- Not much detail about a fast flying item.-      (object1, object2) = partItem CInv $ itemNoDisco (itemBase, 1)-      bname = makePhrase [MU.AW $ MU.Text adj, object1, object2]-      tweakBody b = b { bsymbol = if isShrapnel then bsymbol b else '*'-                      , bcolor = if isShrapnel then bcolor b else Color.BrWhite-                      , bname-                      , bhp = 0-                      , bproj = True-                      , btrajectory = Just (trajectory, speed)-                      , beqp = EM.singleton iid 1-                      , borgan = EM.empty}-      bpronoun = "it"-  void $ addActorIid iid itemFull-                     bfid bpos blid tweakBody bpronoun btime--addActor :: (MonadAtomic m, MonadServer m)-         => Text -> FactionId -> Point -> LevelId-         -> (Actor -> Actor) -> Text -> Time-         -> m (Maybe ActorId)-addActor actorGroup bfid pos lid tweakBody bpronoun time = do-  -- We bootstrap the actor by first creating the trunk of the actor's body-  -- contains the constant properties.-  let trunkFreq = [(actorGroup, 1)]-  m2 <- rollAndRegisterItem lid trunkFreq (CTrunk bfid lid pos) False-  case m2 of-    Nothing -> return Nothing-    Just (trunkId, (trunkFull, _)) ->-      addActorIid trunkId trunkFull bfid pos lid tweakBody bpronoun time--addActorIid :: (MonadAtomic m, MonadServer m)-            => ItemId -> ItemFull -> FactionId -> Point -> LevelId-            -> (Actor -> Actor) -> Text -> Time-            -> m (Maybe ActorId)-addActorIid trunkId trunkFull@ItemFull{..}-            bfid pos lid tweakBody bpronoun time = do-  let trunkKind = case itemDisco of-        Just ItemDisco{itemKind} -> itemKind-        Nothing -> assert `failure` trunkFull-  -- Initial HP and Calm is based only on trunk and ignores organs.-  let hp = xM (max 2 $ sumSlotNoFilter Effect.EqpSlotAddMaxHP [trunkFull])-           `div` 2-      calm = xM $ max 1-             $ sumSlotNoFilter Effect.EqpSlotAddMaxCalm [trunkFull]-  -- Create actor.-  fact@Faction{gplayer} <- getsState $ (EM.! bfid) . sfactionD-  DebugModeSer{sdifficultySer} <- getsServer sdebugSer-  nU <- nUI-  -- If no UI factions, the difficulty applies to heroes (for testing).-  let diffHP | playerUI gplayer || nU == 0 && isHeroFact fact =-        (ceiling :: Double -> Int64)-        $ fromIntegral hp-          * 1.5 ^^ difficultyCoeff sdifficultySer-             | otherwise = hp-      bsymbol = jsymbol itemBase-      bname = jname itemBase-      bcolor = flavourToColor $ jflavour itemBase-      b = actorTemplate trunkId bsymbol bname bpronoun bcolor diffHP calm-                        pos lid time bfid-      -- Insert the trunk as the actor's organ.-      withTrunk = b {borgan = EM.singleton trunkId itemK}-  aid <- getsServer sacounter-  modifyServer $ \ser -> ser {sacounter = succ aid}-  execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(trunkId, itemBase)]-  -- Create, register and insert all initial actor items.-  forM_ (ikit trunkKind) $ \(ikText, cstore) -> do-    let container = CActor aid cstore-        itemFreq = [(ikText, 1)]-    void $ rollAndRegisterItem lid itemFreq container False-  return $ Just aid---- Server has to pick a random weapon or it could leak item discovery--- information. In case of non-projectiles, it only picks items--- with some effects, though, so it leaks properties of completely--- unidentified items.-pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))-pickWeaponServer source = do-  sb <- getsState $ getActorBody source-  eqpAssocs <- fullAssocsServer source [CEqp]-  bodyAssocs <- fullAssocsServer source [COrgan]-  -- For projectiles we need to accept even items without any effect,-  -- so that the projectile dissapears and NoEffect feedback is produced.-  let allAssocs = eqpAssocs ++ bodyAssocs-      strongest | bproj sb = map (1,) eqpAssocs-                | otherwise =-                    strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs-  case strongest of-    [] -> return Nothing-    iis -> do-      let is = map snd iis-      -- TODO: pick the item according to the frequency of its kind.-      (iid, _) <- rndToAction $ oneOf is-      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp-      return $ Just (iid, cstore)--sumOrganEqpServer :: MonadServer m-                 => Effect.EqpSlot -> ActorId -> m Int-sumOrganEqpServer eqpSlot aid = do-  activeAssocs <- activeItemsServer aid-  return $! sumSlotNoFilter eqpSlot activeAssocs--actorSkillsServer :: MonadServer m-                  => ActorId -> Maybe ActorId -> m Ability.Skills-actorSkillsServer aid mleader = do-  activeItems <- activeItemsServer aid-  getsState $ actorSkills aid mleader activeItems
− Game/LambdaHack/Server/DebugServer.hs 
@@ -1,92 +0,0 @@--- | Debug output for requests and responseQs.-module Game.LambdaHack.Server.DebugServer-  ( debugResponseAI, debugResponseUI-  , debugRequestAI, debugRequestUI-  ) where--import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Server.MonadServer---- We debug these on the server, not on the clients, because we want--- a single log, knowing the order in which the server received requests--- and sent responseQs. Clients interleave and block non-deterministically--- so their logs would be harder to interpret.--debugResponseAI :: MonadServer m => ResponseAI -> m ()-debugResponseAI cmd = case cmd of-  RespUpdAtomicAI cmdA@UpdPerception{} -> debugPlain cmd cmdA-  RespUpdAtomicAI cmdA@UpdResume{} -> debugPlain cmd cmdA-  RespUpdAtomicAI cmdA@UpdSpotTile{} -> debugPlain cmd cmdA-  RespUpdAtomicAI cmdA -> debugPretty cmd cmdA-  RespQueryAI aid -> do-    d <- debugAid aid "RespQueryAI" cmd-    debugPrint d-  RespPingAI -> debugPrint $ tshow cmd--debugResponseUI :: MonadServer m => ResponseUI -> m ()-debugResponseUI cmd = case cmd of-  RespUpdAtomicUI cmdA@UpdPerception{} -> debugPlain cmd cmdA-  RespUpdAtomicUI cmdA@UpdResume{} -> debugPlain cmd cmdA-  RespUpdAtomicUI cmdA@UpdSpotTile{} -> debugPlain cmd cmdA-  RespUpdAtomicUI cmdA -> debugPretty cmd cmdA-  RespSfxAtomicUI sfx -> do-    ps <- posSfxAtomic sfx-    debugPrint $ tshow (cmd, ps)-  RespQueryUI -> debugPrint $ "RespQueryUI:" <+> tshow cmd-  RespPingUI -> debugPrint $ tshow cmd--debugPretty :: (MonadServer m, Show a) => a -> UpdAtomic -> m ()-debugPretty cmd cmdA = do-  ps <- posUpdAtomic cmdA-  debugPrint $ tshow (cmd, ps)--debugPlain :: (MonadServer m, Show a) => a -> UpdAtomic -> m ()-debugPlain cmd cmdA = do-  ps <- posUpdAtomic cmdA-  debugPrint $ T.pack $ show (cmd, ps)  -- too large for pretty show--debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m ()-debugRequestAI aid cmd = do-  d <- debugAid aid "AI request" cmd-  debugPrint d--debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m ()-debugRequestUI aid cmd = do-  d <- debugAid aid "UI request" cmd-  debugPrint d--data DebugAid a = DebugAid-  { label   :: !Text-  , cmd     :: !a-  , lid     :: !LevelId-  , time    :: !Time-  , aid     :: !ActorId-  , faction :: !FactionId-  }-  deriving Show--debugAid :: (MonadStateRead m, Show a) => ActorId -> Text -> a -> m Text-debugAid aid label cmd =-  if aid == toEnum (-1) then-    return $ "Pong:" <+> tshow label <+> tshow cmd-  else do-    b <- getsState $ getActorBody aid-    time <- getsState $ getLocalTime (blid b)-    return $! tshow DebugAid { label-                             , cmd-                             , lid = blid b-                             , time-                             , aid-                             , faction = bfid b }
− Game/LambdaHack/Server/DungeonGen.hs 
@@ -1,280 +0,0 @@--- | The unpopulated dungeon generation routine.-module Game.LambdaHack.Server.DungeonGen-  ( -- * Public API-    FreshDungeon(..), dungeonGen-    -- * Internal functions-  , convertTileMaps, placeStairs, buildLevel, levelFromCaveKind, findGenerator-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.IntMap.Strict as IM-import Data.List-import Data.Maybe-import Data.Text (Text)--import qualified Game.LambdaHack.Common.Effect as Effect-import qualified Game.LambdaHack.Common.Feature as F-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.CaveKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Server.DungeonGen.Area-import Game.LambdaHack.Server.DungeonGen.Cave-import Game.LambdaHack.Server.DungeonGen.Place--convertTileMaps :: Kind.Ops TileKind-                -> Rnd (Kind.Id TileKind) -> Maybe (Rnd (Kind.Id TileKind))-                -> Int -> Int -> TileMapEM-                -> Rnd TileMap-convertTileMaps cotile cdefTile mcdefTileWalkable cxsize cysize ltile = do-  let f :: Point -> Rnd (Kind.Id TileKind)-      f p = case EM.lookup p ltile of-        Just t -> return t-        Nothing -> cdefTile-  converted1 <- PointArray.generateMA cxsize cysize f-  case mcdefTileWalkable of-    Nothing -> return converted1  -- no walkable tiles for filling the map-    Just cdefTileWalkable -> do  -- some tiles walkable, so ensure connectivity-      -- TODO: perhaps checking connectivity with BFS would be better,-      -- but it's still artibrary how we recover connectivity and we still-      -- need ltile not to break rooms (unless that's a good idea,-      -- but surely it's not for starship hull walls, vaults, fire pits, etc.,-      -- so perhaps all but impenetrable walls is game).-      let passes p@Point{..} array =-            px >= 0 && px <= cxsize - 1-            && py >= 0 && py <= cysize - 1-            && Tile.isWalkable cotile (array PointArray.! p)-          -- If no point blocks on both ends, then I can eventually go-          -- from bottom to top of the map and from left to right-          -- unless there are disconnected areas inside rooms).-          blocksHorizontal (Point x y) array =-            not (passes (Point (x + 1) y) array-                 || passes (Point (x - 1) y) array)-          blocksVertical (Point x y) array =-            not (passes (Point x (y + 1)) array-                 || passes (Point x (y - 1)) array)-          xeven Point{..} = px `mod` 2 == 0-          yeven Point{..} = py `mod` 2 == 0-          connect included blocks walkableTile array =-            let g n c = if included n-                           && not (Tile.isWalkable cotile c)-                           && n `EM.notMember` ltile-                           && blocks n array-                        then walkableTile-                        else c-            in PointArray.imapA g array-      walkable2 <- cdefTileWalkable-      let converted2 = connect xeven blocksHorizontal walkable2 converted1-      walkable3 <- cdefTileWalkable-      let converted3 = connect yeven blocksVertical walkable3 converted2-      walkable4 <- cdefTileWalkable-      let converted4 =-            connect (not . xeven) blocksHorizontal walkable4 converted3-      walkable5 <- cdefTileWalkable-      let converted5 =-            connect (not . yeven) blocksVertical walkable5 converted4-      return converted5--placeStairs :: Kind.Ops TileKind -> TileMap -> CaveKind -> [Point]-            -> Rnd Point-placeStairs cotile cmap CaveKind{..} ps = do-  let dist cmin l _ = all (\pos -> chessDist l pos > cmin) ps-  findPosTry 1000 cmap-    (\p t -> Tile.isWalkable cotile t-             && not (Tile.hasFeature cotile F.NoActor t)-             && dist 0 p t)  -- can't overwrite stairs with other stairs-    [ dist $ cminStairDist-    , dist $ cminStairDist `div` 2-    , dist $ cminStairDist `div` 4-    , const $ Tile.hasFeature cotile F.OftenActor-    , dist $ cminStairDist `div` 8-    ]---- | Create a level from a cave.-buildLevel :: Kind.COps -> Cave-           -> AbsDepth -> LevelId -> LevelId -> LevelId -> AbsDepth-           -> Int -> Maybe Bool-           -> Rnd Level-buildLevel cops@Kind.COps{ cotile=cotile@Kind.Ops{opick, okind}-                         , cocave=Kind.Ops{okind=cokind} }-           Cave{..} ldepth ln minD maxD totalDepth nstairUp escapeFeature = do-  let kc@CaveKind{..} = cokind dkind-      fitArea pos = inside pos . fromArea . qarea-      findLegend pos = maybe clegendLitTile qlegend-                       $ find (fitArea pos) dplaces-      hasEscape p t = Tile.kindHasFeature (F.Cause $ Effect.Escape p) t-      ascendable  = Tile.kindHasFeature $ F.Cause (Effect.Ascend 1)-      descendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend (-1))-      nightCond kt = (not (Tile.kindHasFeature F.Clear kt)-                      || (if dnight then id else not)-                            (Tile.kindHasFeature F.Dark kt))-      dcond kt = (cpassable-                  || not (Tile.kindHasFeature F.Walkable kt))-                 && nightCond kt-      pickDefTile = fmap (fromMaybe $ assert `failure` cdefTile)-                    $ opick cdefTile dcond-      wcond kt = Tile.kindHasFeature F.Walkable kt-                 && nightCond kt-      mpickWalkable =-        if cpassable-        then Just $ fmap (fromMaybe $ assert `failure` cdefTile)-                  $ opick cdefTile wcond-        else Nothing-  cmap <- convertTileMaps cotile pickDefTile mpickWalkable cxsize cysize dmap-  -- We keep two-way stairs separately, in the last component.-  let makeStairs :: Bool -> Bool -> Bool-                 -> ( [(Point, Kind.Id TileKind)]-                    , [(Point, Kind.Id TileKind)]-                    , [(Point, Kind.Id TileKind)] )-                 -> Rnd ( [(Point, Kind.Id TileKind)]-                        , [(Point, Kind.Id TileKind)]-                        , [(Point, Kind.Id TileKind)] )-      makeStairs moveUp noAsc noDesc (up, down, upDown) =-        if (if moveUp then noAsc else noDesc) then-          return (up, down, upDown)-        else do-          let cond tk = (if moveUp then ascendable tk else descendable tk)-                        && (if noAsc then not (ascendable tk) else True)-                        && (if noDesc then not (descendable tk) else True)-              stairsCur = up ++ down ++ upDown-              posCur = nub $ sort $ map fst stairsCur-          spos <- placeStairs cotile cmap kc posCur-          let legend = findLegend spos-          stairId <- fmap (fromMaybe $ assert `failure` legend)-                     $ opick legend cond-          let st = (spos, stairId)-              asc = ascendable $ okind stairId-              desc = descendable $ okind stairId-          return $! case (asc, desc) of-                     (True, False) -> (st : up, down, upDown)-                     (False, True) -> (up, st : down, upDown)-                     (True, True)  -> (up, down, st : upDown)-                     (False, False) -> assert `failure` st-  (stairsUp1, stairsDown1, stairsUpDown1) <--    makeStairs False (ln == maxD) (ln == minD) ([], [], [])-  assert (null stairsUp1) skip-  let nstairUpLeft = nstairUp - length stairsUpDown1-  (stairsUp2, stairsDown2, stairsUpDown2) <--    foldM (\sts _ -> makeStairs True (ln == maxD) (ln == minD) sts)-          (stairsUp1, stairsDown1, stairsUpDown1)-          [1 .. nstairUpLeft]-  -- If only a single tile of up-and-down stairs, add one more stairs down.-  (stairsUp, stairsDown, stairsUpDown) <--    if length (stairsUp2 ++ stairsDown2) == 0-    then (makeStairs False True (ln == minD)-             (stairsUp2, stairsDown2, stairsUpDown2))-    else return (stairsUp2, stairsDown2, stairsUpDown2)-  let stairsUpAndUpDown = stairsUp ++ stairsUpDown-  assert (length stairsUpAndUpDown == nstairUp) skip-  let stairsTotal = stairsUpAndUpDown ++ stairsDown-      posTotal = nub $ sort $ map fst stairsTotal-  epos <- placeStairs cotile cmap kc posTotal-  escape <- case escapeFeature of-              Nothing -> return []-              Just True -> do-                let legend = findLegend epos-                upEscape <- fmap (fromMaybe $ assert `failure` legend)-                            $ opick legend $ hasEscape 1-                return [(epos, upEscape)]-              Just False -> do-                let legend = findLegend epos-                downEscape <- fmap (fromMaybe $ assert `failure` legend)-                              $ opick legend $ hasEscape (-1)-                return [(epos, downEscape)]-  let exits = stairsTotal ++ escape-      ltile = cmap PointArray.// exits-      -- We reverse the order in down stairs, to minimize long stair chains.-      lstair = ( map fst $ stairsUp ++ stairsUpDown-               , map fst $ stairsUpDown ++ stairsDown )-  -- traceShow (ln, nstairUp, (stairsUp, stairsDown, stairsUpDown)) skip-  litemNum <- castDice ldepth totalDepth citemNum-  lsecret <- randomR (1, maxBound)  -- 0 means unknown-  return $! levelFromCaveKind cops kc ldepth ltile lstair-                              cactorFreq litemNum citemFreq-                              lsecret (isJust escapeFeature)---- | Build rudimentary level from a cave kind.-levelFromCaveKind :: Kind.COps-                  -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point])-                  -> Freqs -> Int -> Freqs -> Int -> Bool-                  -> Level-levelFromCaveKind Kind.COps{cotile}-                  CaveKind{..}-                  ldepth ltile lstair lactorFreq litemNum litemFreq-                  lsecret lescape =-  let lvl = Level-        { ldepth-        , lprio = EM.empty-        , lfloor = EM.empty-        , ltile-        , lxsize = cxsize-        , lysize = cysize-        , lsmell = EM.empty-        , ldesc = cname-        , lstair-        , lseen = 0-        , lclear = 0  -- calculated below-        , ltime = timeZero-        , lactorFreq-        , litemNum-        , litemFreq-        , lsecret-        , lhidden = chidden-        , lescape-        }-      f n t | Tile.isExplorable cotile t = n + 1-            | otherwise = n-      lclear = PointArray.foldlA f 0 ltile-  in lvl {lclear}--findGenerator :: Kind.COps -> LevelId -> LevelId -> LevelId -> AbsDepth -> Int-              -> (Text, Maybe Bool)-              -> Rnd Level-findGenerator cops ln minD maxD totalDepth nstairUp-              (genName, escapeFeature) = do-  let Kind.COps{cocave=Kind.Ops{opick}} = cops-  ci <- fmap (fromMaybe $ assert `failure` genName)-        $ opick genName (const True)-  -- A simple rule for now: level at level @ln@ has depth (difficulty) @abs ln@.-  let ldepth = AbsDepth $ abs $ fromEnum ln-  cave <- buildCave cops ldepth totalDepth ci-  buildLevel cops cave ldepth ln minD maxD totalDepth nstairUp escapeFeature---- | Freshly generated and not yet populated dungeon.-data FreshDungeon = FreshDungeon-  { freshDungeon    :: !Dungeon   -- ^ maps for all levels-  , freshTotalDepth :: !AbsDepth  -- ^ absolute dungeon depth-  }---- | Generate the dungeon for a new game.-dungeonGen :: Kind.COps -> Caves -> Rnd FreshDungeon-dungeonGen cops caves = do-  let (minD, maxD) =-        case (IM.minViewWithKey caves, IM.maxViewWithKey caves) of-          (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` "no caves" `twith` caves-      (minId, maxId) = (toEnum minD, toEnum maxD)-      freshTotalDepth = assert (signum minD == signum maxD)-                        $ AbsDepth-                        $ max 10 $ max (abs minD) (abs maxD)-  let gen :: (Int, [(LevelId, Level)]) -> (Int, (Text, Maybe Bool))-          -> Rnd (Int, [(LevelId, Level)])-      gen (nstairUp, l) (n, caveTB) = do-        let ln = toEnum n-        lvl <- findGenerator cops ln minId maxId freshTotalDepth nstairUp caveTB-        -- nstairUp for the next level is nstairDown for the current level-        let nstairDown = length $ snd $ lstair lvl-        return $ (nstairDown, (ln, lvl) : l)-  (nstairUpLast, levels) <- foldM gen (0, []) $ reverse $ IM.assocs caves-  assert (nstairUpLast == 0) skip-  let freshDungeon = EM.fromList levels-  return $! FreshDungeon{..}
− Game/LambdaHack/Server/DungeonGen/Area.hs 
@@ -1,53 +0,0 @@--- | Rectangular areas of levels and their basic operations.-module Game.LambdaHack.Server.DungeonGen.Area-  ( Area, toArea, fromArea, trivialArea, grid, shrink-  ) where--import Data.Binary--import Game.LambdaHack.Common.Point---- | The type of areas. The bottom left and the top right points.-data Area = Area !X !Y !X !Y-  deriving Show---- | Checks if it's an area with at least one field.-toArea :: (X, Y, X, Y) -> Maybe Area-toArea (x0, y0, x1, y1) = if x0 <= x1 && y0 <= y1-                          then Just $ Area x0 y0 x1 y1-                          else Nothing--fromArea :: Area -> (X, Y, X, Y)-fromArea (Area x0 y0 x1 y1) = (x0, y0, x1, y1)--trivialArea :: Point -> Area-trivialArea (Point x y) = Area x y x y---- | Divide uniformly a larger area into the given number of smaller areas--- overlapping at the edges.-grid :: (X, Y) -> Area -> [(Point, Area)]-grid (nx, ny) (Area x0 y0 x1 y1) =-  let xd = x1 - x0  -- not +1, because we need overlap-      yd = y1 - y0-  in [ (Point x y, Area (x0 + xd * x `div` nx)-                          (y0 + yd * y `div` ny)-                          (x0 + xd * (x + 1) `div` nx)-                          (y0 + yd * (y + 1) `div` ny))-     | x <- [0..nx-1], y <- [0..ny-1] ]---- | Enlarge (or shrink) the given area on all fours sides by the amount.-shrink :: Area -> Maybe Area-shrink (Area x0 y0 x1 y1) = toArea (x0 + 1, y0 + 1, x1 - 1, y1 - 1)--instance Binary Area where-  put (Area x0 y0 x1 y1) = do-    put x0-    put y0-    put x1-    put y1-  get = do-    x0 <- get-    y0 <- get-    x1 <- get-    y1 <- get-    return (Area x0 y0 x1 y1)
− Game/LambdaHack/Server/DungeonGen/AreaRnd.hs 
@@ -1,185 +0,0 @@--- | Operations on the 'Area' type that involve random numbers.-module Game.LambdaHack.Server.DungeonGen.AreaRnd-  ( -- * Picking points inside areas-    xyInArea, mkRoom, mkVoidRoom-    -- * Choosing connections-  , connectGrid, randomConnection-    -- * Plotting corridors-  , Corridor, connectPlaces-  ) where--import Control.Exception.Assert.Sugar-import Data.Maybe-import qualified Data.Set as S--import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Server.DungeonGen.Area---- Picking random points inside areas---- | Pick a random point within an area.-xyInArea :: Area -> Rnd Point-xyInArea area = do-  let (x0, y0, x1, y1) = fromArea area-  rx <- randomR (x0, x1)-  ry <- randomR (y0, y1)-  return $! Point rx ry---- | Create a random room according to given parameters.-mkRoom :: (X, Y)    -- ^ minimum size-       -> (X, Y)    -- ^ maximum size-       -> Area      -- ^ the containing area, not the room itself-       -> Rnd Area-mkRoom (xm, ym) (xM, yM) area = do-  let (x0, y0, x1, y1) = fromArea area-  assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) skip-  let aW = (xm, ym, min xM (x1 - x0 + 1), min yM (y1 - y0 + 1))-      areaW = fromMaybe (assert `failure` aW) $ toArea aW-  Point xW yW <- xyInArea areaW  -- roll size-  let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1))-      area1 = fromMaybe (assert `failure` a1) $ toArea a1-  Point rx1 ry1 <- xyInArea area1  -- roll top-left corner-  let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1)-      area3 = fromMaybe (assert `failure` a3) $ toArea a3-  return $! area3---- | Create a void room, i.e., a single point area within the designated area.-mkVoidRoom :: Area -> Rnd Area-mkVoidRoom area = do-  -- Pass corridors closer to the middle of the grid area, if possible.-  let core = fromMaybe area $ shrink area-  pxy <- xyInArea core-  return $! trivialArea pxy---- Choosing connections between areas in a grid---- | Pick a subset of connections between adjacent areas within a grid until--- there is only one connected component in the graph of all areas.-connectGrid :: (X, Y) -> Rnd [(Point, Point)]-connectGrid (nx, ny) = do-  let unconnected = S.fromList [ Point x y-                               | x <- [0..nx-1], y <- [0..ny-1] ]-  -- Candidates are neighbours that are still unconnected. We start with-  -- a random choice.-  rx <- randomR (0, nx-1)-  ry <- randomR (0, ny-1)-  let candidates = S.fromList [Point rx ry]-  connectGrid' (nx, ny) unconnected candidates []--connectGrid' :: (X, Y) -> S.Set Point -> S.Set Point-             -> [(Point, Point)]-             -> Rnd [(Point, Point)]-connectGrid' (nx, ny) unconnected candidates acc-  | S.null candidates = return $! map sortPoint acc-  | otherwise = do-      c <- oneOf (S.toList candidates)-      -- potential new candidates:-      let ns = S.fromList $ vicinityCardinal nx ny 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)---- | Sort the sequence of two points, in the derived lexicographic order.-sortPoint :: (Point, Point) -> (Point, Point)-sortPoint (a, b) | a <= b    = (a, b)-                 | otherwise = (b, a)---- | Pick a single random connection between adjacent areas within a grid.-randomConnection :: (X, Y) -> Rnd (Point, Point)-randomConnection (nx, ny) =-  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` "wrong connection"-                                               `twith` (nx, ny)) $ do-  rb <- oneOf [False, True]-  if rb || ny <= 1-    then do-      rx  <- randomR (0, nx-2)-      ry  <- randomR (0, ny-1)-      return (Point rx ry, Point (rx+1) ry)-    else do-      rx  <- randomR (0, nx-1)-      ry  <- randomR (0, ny-2)-      return (Point rx ry, Point 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 = [Point]---- | Create a corridor, either horizontal or vertical, with--- a possible intermediate part that is in the opposite direction.-mkCorridor :: HV            -- ^ orientation of the starting section-           -> Point       -- ^ starting point-           -> Point       -- ^ ending point-           -> Area          -- ^ the area containing the intermediate point-           -> Rnd Corridor  -- ^ straight sections of the corridor-mkCorridor hv (Point x0 y0) (Point x1 y1) b = do-  Point rx ry <- xyInArea b-  return $! map (uncurry Point) $ case hv of-    Horiz -> [(x0, y0), (rx, y0), (rx, y1), (x1, y1)]-    Vert  -> [(x0, y0), (x0, ry), (x1, ry), (x1, y1)]---- | Try to connect two interiors of places with a corridor.--- Choose entrances at least 4 or 3 tiles distant from the edges, if the place--- is big enough. Note that with @pfence == FNone@, the area considered--- is the strict interior of the place, without the outermost tiles.-connectPlaces :: (Area, Area) -> (Area, Area) -> Rnd Corridor-connectPlaces (sa, so) (ta, to) = do-  let (_, _, sx1, sy1) = fromArea sa-      (_, _, sox1, soy1) = fromArea so-      (tx0, ty0, _, _) = fromArea ta-      (tox0, toy0, _, _) = fromArea to-  assert (sx1 <= tx0  || sy1 <= ty0  `blame` (sa, ta)) skip-  assert (sx1 <= sox1 || sy1 <= soy1 `blame` (sa, so)) skip-  assert (tx0 >= tox0 || ty0 >= toy0 `blame` (ta, to)) skip-  let trim area =-        let (x0, y0, x1, y1) = fromArea area-            trim4 (v0, v1) | v1 - v0 < 6 = (v0, v1)-                           | v1 - v0 < 8 = (v0 + 3, v1 - 3)-                           | otherwise = (v0 + 4, v1 - 4)-            (nx0, nx1) = trim4 (x0, x1)-            (ny0, ny1) = trim4 (y0, y1)-        in fromMaybe (assert `failure` area) $ toArea (nx0, ny0, nx1, ny1)-  Point sx sy <- xyInArea $ trim so-  Point tx ty <- xyInArea $ trim to-  let hva sarea tarea = do-        let (_, _, zsx1, zsy1) = fromArea sarea-            (ztx0, zty0, _, _) = fromArea tarea-            xa = (zsx1+2, min sy ty, ztx0-2, max sy ty)-            ya = (min sx tx, zsy1+2, max sx tx, zty0-2)-            xya = (zsx1+2, zsy1+2, ztx0-2, zty0-2)-        case toArea xya of-          Just xyarea -> fmap (\hv -> (hv, Just xyarea)) (oneOf [Horiz, Vert])-          Nothing ->-            case toArea xa of-              Just xarea -> return (Horiz, Just xarea)-              Nothing -> return (Vert, toArea ya) -- Vertical bias.-  (hvOuter, areaOuter) <- hva so to-  (hv, area) <- case areaOuter of-    Just arenaOuter -> return (hvOuter, arenaOuter)-    Nothing -> do-      -- TODO: let mkCorridor only pick points on the floor fence-      (hvInner, aInner) <- hva sa ta-      let yell = assert `failure` (sa, so, ta, to, areaOuter, aInner)-          areaInner = fromMaybe yell aInner-      return (hvInner, areaInner)-  -- We cross width one places completely with the corridor, for void-  -- rooms and others (e.g., one-tile wall room then becomes a door, etc.).-  let (p0, p1) = case hv of-        Horiz -> (Point sox1 sy, Point tox0 ty)-        Vert  -> (Point sx soy1, Point tx toy0)-  -- The condition imposed on mkCorridor are tricky: there might not always-  -- exist a good intermediate point if the places are allowed to be close-  -- together and then we let the intermediate part degenerate.-  mkCorridor hv p0 p1 area
− Game/LambdaHack/Server/DungeonGen/Cave.hs 
@@ -1,185 +0,0 @@--- | Generation of caves (not yet inhabited dungeon levels) from cave kinds.-module Game.LambdaHack.Server.DungeonGen.Cave-  ( Cave(..), buildCave-  ) where--import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Key (mapWithKeyM)-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe--import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.CaveKind-import Game.LambdaHack.Content.PlaceKind-import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Server.DungeonGen.Area-import Game.LambdaHack.Server.DungeonGen.AreaRnd-import Game.LambdaHack.Server.DungeonGen.Place---- | The type of caves (not yet inhabited dungeon levels).-data Cave = Cave-  { dkind   :: !(Kind.Id CaveKind)  -- ^ the kind of the cave-  , dmap    :: !TileMapEM           -- ^ tile kinds in the cave-  , dplaces :: ![Place]             -- ^ places generated in the cave-  , dnight  :: !Bool                -- ^ whether the cave is dark-  }-  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 position-    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-          -> AbsDepth          -- ^ depth of the level to generate-          -> AbsDepth          -- ^ absolute depth-          -> Kind.Id CaveKind  -- ^ cave kind to use for generation-          -> Rnd Cave-buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{opick}-                        , cocave=Kind.Ops{okind}-                        , coplace=Kind.Ops{okind=pokind} }-          ldepth totalDepth dkind = do-  let kc@CaveKind{..} = okind dkind-  lgrid@(gx, gy) <- castDiceXY ldepth totalDepth cgrid-  -- Make sure that in caves not filled with rock, there is a passage-  -- across the cave, even if a single room blocks most of the cave.-  -- Also, ensure fancy outer fences are not obstructed by room walls.-  let fullArea = fromMaybe (assert `failure` kc)-                 $ toArea (0, 0, cxsize - 1, cysize - 1)-      subFullArea = fromMaybe (assert `failure` kc)-                    $ toArea (1, 1, cxsize - 2, cysize - 2)-      area | gx * gy == 1-             || couterFenceTile /= "basic outer fence" = subFullArea-           | otherwise = fullArea-      gs = grid lgrid area-  (addedConnects, voidPlaces) <- do-    if gx * gy > 1 then do-       let fractionOfPlaces r = round $ r * fromIntegral (gx * gy)-           cauxNum = fractionOfPlaces cauxConnects-       addedC <- replicateM cauxNum (randomConnection lgrid)-       let gridArea = fromMaybe (assert `failure` lgrid)-                      $ toArea (0, 0, gx - 1, gy - 1)-           voidNum = fractionOfPlaces cmaxVoid-       voidPl <- replicateM voidNum $ xyInArea gridArea  -- repetitions are OK-       return (addedC, voidPl)-    else return ([], [])-  minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize-  maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize-  places0 <- mapM (\ (i, r) -> do-                     -- Reserved for corridors and the global fence.-                     let innerArea = fromMaybe (assert `failure` (i, r))-                                     $ shrink r-                     r' <- if i `elem` voidPlaces-                           then fmap Left $ mkVoidRoom innerArea-                           else fmap Right $ mkRoom minPlaceSize-                                                    maxPlaceSize innerArea-                     return (i, r')) gs-  fence <- buildFenceRnd cops couterFenceTile subFullArea-  dnight <- chanceDice ldepth totalDepth cnightChance-  darkCorTile <- fmap (fromMaybe $ assert `failure` cdarkCorTile)-                 $ opick cdarkCorTile (const True)-  litCorTile <- fmap (fromMaybe $ assert `failure` clitCorTile)-                $ opick clitCorTile (const True)-  let pickedCorTile = if dnight then darkCorTile else litCorTile-      addPl (m, pls, qls) (i, Left r) = return (m, pls, (i, Left r) : qls)-      addPl (m, pls, qls) (i, Right r) = do-        (tmap, place) <--          buildPlace cops kc dnight darkCorTile litCorTile ldepth totalDepth r-        return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls)-  (lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0-  connects <- connectGrid lgrid-  let allConnects = union connects addedConnects  -- no duplicates-      qplaces = M.fromList qplaces0-  cs <- mapM (\(p0, p1) -> do-                let shrinkPlace (r, Place{qkind}) =-                      case shrink r of-                        Nothing -> (r, r)  -- FNone place of x and/or y size 1-                        Just sr -> case pfence $ pokind qkind of-                          FFloor ->-                            -- Avoid corridors touching the floor fence,-                            -- but let them merge with the fence.-                            case shrink sr of-                              Nothing -> (sr, r)-                              Just mergeArea -> (mergeArea, r)-                          _ -> (sr, sr)-                    shrinkForFence = either (id &&& id) shrinkPlace-                    rr0 = shrinkForFence $ qplaces M.! p0-                    rr1 = shrinkForFence $ qplaces M.! p1-                connectPlaces rr0 rr1) allConnects-  let lcorridors = EM.unions (map (digCorridors pickedCorTile) cs)-      lm = EM.union lplaces lcorridors-  -- Convert wall openings into doors, possibly.-  let f pos (t, cor) = do-        -- Openings have a certain chance to be doors-        -- and doors have a certain chance to be open.-        rd <- chance cdoorChance-        if not rd then  -- opening kept-          if Tile.isLit cotile cor then return cor-          else do-            -- If any adjacent room tile is lit, make the opening lit.-            let roomTileLit p =-                  case EM.lookup p lplaces of-                    Nothing -> False-                    Just tile -> Tile.isLit cotile tile-                vic = vicinity cxsize cysize pos-            if any roomTileLit vic-              then return litCorTile-              else return cor-        else do-          ro <- chance copenChance-          doorClosedId <- Tile.revealAs cotile t-          if not ro then return $! doorClosedId-          else do-            doorOpenId <- Tile.openTo cotile doorClosedId-            return $! doorOpenId-      mergeCor _ pl cor =-        let hidden = Tile.hideAs cotile pl-        in if hidden == pl then Nothing else Just (hidden, cor)-      intersectionCombine combine =-        EM.mergeWithKey combine (const EM.empty) (const EM.empty)-      interCor = intersectionCombine mergeCor lplaces lcorridors-  doorMap <- mapWithKeyM f interCor-  let dmap = EM.union doorMap lm-      cave = Cave-        { dkind-        , dmap-        , dplaces-        , dnight-        }-  return $! cave--digCorridors :: Kind.Id TileKind -> Corridor -> TileMapEM-digCorridors tile (p1:p2:ps) =-  EM.union corPos (digCorridors tile (p2:ps))- where-  cor  = fromTo p1 p2-  corPos = EM.fromList $ zip cor (repeat tile)-digCorridors _ _ = EM.empty
− Game/LambdaHack/Server/DungeonGen/Place.hs 
@@ -1,266 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- | Generation of places from place kinds.-module Game.LambdaHack.Server.DungeonGen.Place-  ( TileMapEM, Place(..), placeCheck, buildFenceRnd, buildPlace-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Common.Frequency-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Content.CaveKind-import Game.LambdaHack.Content.PlaceKind-import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Server.DungeonGen.Area---- TODO: use more, rewrite as needed, document each field.--- | The parameters of a place. Most are immutable and set--- at the time when a place is generated.-data Place = Place-  { qkind        :: !(Kind.Id PlaceKind)-  , qarea        :: !Area-  , qseen        :: !Bool-  , qlegend      :: !Text-  , qsolidFence  :: !(Kind.Id TileKind)-  , qhollowFence :: !(Kind.Id TileKind)-  }-  deriving Show---- | The map of tile kinds in a place (and generally anywhere in a cave).--- The map is sparse. The default tile that eventually fills the empty spaces--- is specified in the cave kind specification with @cdefTile@.-type TileMapEM = EM.EnumMap Point (Kind.Id TileKind)---- | For @CAlternate@ tiling, require the place be comprised--- of an even number of whole corners, with exactly one square--- overlap between consecutive coners and no trimming.--- For other tiling methods, check that the area is large enough for tiling--- the corner twice in each direction, with a possible one row/column overlap.-placeCheck :: Area       -- ^ the area to fill-           -> PlaceKind  -- ^ the place kind to construct-           -> Bool-placeCheck r PlaceKind{..} =-  case interiorArea pfence r of-    Nothing -> False-    Just area ->-      let (x0, y0, x1, y1) = fromArea area-          dx = x1 - x0 + 1-          dy = y1 - y0 + 1-          dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l-          dycorner = length ptopLeft-          wholeOverlapped d dcorner = d > 1 && dcorner > 1 &&-                                      (d - 1) `mod` (2 * (dcorner - 1)) == 0-          largeEnough = dx >= 2 * dxcorner - 1 && dy >= 2 * dycorner - 1-      in case pcover of-        CAlternate -> wholeOverlapped dx dxcorner &&-                      wholeOverlapped dy dycorner-        CStretch   -> largeEnough-        CReflect   -> largeEnough-        CVerbatim  -> dx >= dxcorner && dy >= dycorner---- | Calculate interior room area according to fence type, based on the--- total area for the room and it's fence. This is used for checking--- if the room fits in the area, for digging up the place and the fence--- and for deciding if the room is dark or lit later in the dungeon--- generation process (e.g., for stairs).-interiorArea :: Fence -> Area -> Maybe Area-interiorArea fence r = case fence of-  FWall  -> shrink r-  FFloor -> shrink r-  FNone  -> Just r---- | Given a few parameters, roll and construct a 'Place' datastructure--- and fill a cave section acccording to it.-buildPlace :: Kind.COps         -- ^ the game content-           -> CaveKind          -- ^ current cave kind-           -> Bool              -- ^ whether the cave is dark-           -> Kind.Id TileKind  -- ^ dark fence tile, if fence hollow-           -> Kind.Id TileKind  -- ^ lit fence tile, if fence hollow-           -> AbsDepth          -- ^ current level depth-           -> AbsDepth          -- ^ absolute depth-           -> Area              -- ^ whole area of the place, fence included-           -> Rnd (TileMapEM, Place)-buildPlace Kind.COps{ cotile=cotile@Kind.Ops{opick=opick}-                    , coplace=Kind.Ops{ofoldrGroup} }-           CaveKind{..} dnight darkCorTile litCorTile-           ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) r = do-  qsolidFence <- fmap (fromMaybe $ assert `failure` cfillerTile)-                 $ opick cfillerTile (const True)-  dark <- chanceDice ldepth totalDepth cdarkChance-  -- TODO: factor out from here and newItem:-  let findInterval x1y1 [] = (x1y1, (11, 0))-      findInterval x1y1 ((x, y) : rest) =-        if ld * 10 <= x * depth-        then (x1y1, (x, y))-        else findInterval (x, y) rest-      linearInterpolation dataset =-        -- We assume @dataset@ is sorted and between 1 and 10 inclusive.-        let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset-        in y1 + (y2 - y1) * (ld * 10 - x1 * depth)-           `divUp` ((x2 - x1) * depth)-  let f placeGroup q p pk kind acc =-        let rarity = linearInterpolation (prarity kind)-        in (q * p * rarity, ((pk, kind), placeGroup)) : acc-      g (placeGroup, q) = ofoldrGroup placeGroup (f placeGroup q) []-      placeFreq = concatMap g cplaceFreq-      checkedFreq = filter (\(_, ((_, kind), _)) -> placeCheck r kind) placeFreq-      freq = toFreq ("buildPlace ('" <> tshow ld <> ")") checkedFreq-  assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) skip-  ((qkind, kr), _) <- frequency freq-  let qhollowFence = if dark then darkCorTile else litCorTile-      qlegend = if dark then clegendDarkTile else clegendLitTile-      qseen = False-      qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea (pfence kr) r-      place = Place {..}-  override <- ooverride cotile (poverride kr)-  legend <- olegend cotile qlegend-  legendLit <- olegend cotile clegendLitTile-  let xlegend = EM.union override legend-      xlegendLit = EM.union override legendLit-      cmap = tilePlace qarea kr-      fence = case pfence kr of-        FWall -> buildFence qsolidFence qarea-        FFloor -> buildFence qhollowFence qarea-        FNone -> EM.empty-      (x0, y0, x1, y1) = fromArea qarea-      isEdge (Point x y) = x `elem` [x0, x1] || y `elem` [y0, y1]-      digDay xy c | isEdge xy = xlegendLit EM.! c-                  | otherwise = xlegend EM.! c-      interior = case pfence kr of-        FNone | not dnight -> EM.mapWithKey digDay cmap-        _ -> let lookupLegend x = fromMaybe (assert `failure` (qlegend, x))-                                  $ EM.lookup x xlegend-             in EM.map lookupLegend cmap-      tmap = EM.union interior fence-  return (tmap, place)---- | Roll a legend of a place plan: a map from plan symbols to tile kinds.-olegend :: Kind.Ops TileKind -> Text-        -> Rnd (EM.EnumMap Char (Kind.Id TileKind))-olegend Kind.Ops{ofoldrWithKey, opick} cgroup =-  let getSymbols _ tk acc =-        maybe acc (const $ ES.insert (tsymbol tk) acc)-          (lookup cgroup $ tfreq tk)-      symbols = ofoldrWithKey getSymbols ES.empty-      getLegend s acc = do-        m <- acc-        tk <- fmap (fromMaybe $ assert `failure` (cgroup, s))-              $ opick cgroup $ (== s) . tsymbol-        return $! EM.insert s tk m-      legend = ES.foldr getLegend (return EM.empty) symbols-  in legend--ooverride :: Kind.Ops TileKind -> [(Char, Text)]-          -> Rnd (EM.EnumMap Char (Kind.Id TileKind))-ooverride Kind.Ops{opick} poverride =-  let getLegend (s, cgroup) acc = do-        m <- acc-        tk <- fmap (fromMaybe $ assert `failure` (cgroup, s))-              $ opick cgroup (const True)  -- tile symbol ignored-        return $! EM.insert s tk m-      legend = foldr getLegend (return EM.empty) poverride-  in legend---- | Construct a fence around an area, with the given tile kind.-buildFence :: Kind.Id TileKind -> Area -> TileMapEM-buildFence fenceId area =-  let (x0, y0, x1, y1) = fromArea area-  in EM.fromList $ [ (Point x y, fenceId)-                   | x <- [x0-1, x1+1], y <- [y0..y1] ] ++-                   [ (Point x y, fenceId)-                   | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]---- | Construct a fence around an area, with the given tile group.-buildFenceRnd :: Kind.COps -> Text -> Area -> Rnd TileMapEM-buildFenceRnd Kind.COps{cotile=Kind.Ops{opick}} couterFenceTile area = do-  let (x0, y0, x1, y1) = fromArea area-      fenceIdRnd (xf, yf) = do-        let isCorner x y = x `elem` [x0-1, x1+1] && y `elem` [y0-1, y1+1]-            tileGroup | isCorner xf yf = "basic outer fence"-                      | otherwise = couterFenceTile-        fenceId <- fmap (fromMaybe $ assert `failure` tileGroup)-                   $ opick tileGroup (const True)-        return (Point xf yf, fenceId)-      pointList = [ (x, y) | x <- [x0-1, x1+1], y <- [y0..y1] ]-                  ++ [ (x, y) | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ]-  fenceList <- mapM fenceIdRnd pointList-  return $! EM.fromList fenceList---- TODO: use Text more instead of [Char]?--- | Create a place by tiling patterns.-tilePlace :: Area                           -- ^ the area to fill-          -> PlaceKind                      -- ^ the place kind to construct-          -> EM.EnumMap Point Char-tilePlace area pl@PlaceKind{..} =-  let (x0, y0, x1, y1) = fromArea area-      xwidth = x1 - x0 + 1-      ywidth = y1 - y0 + 1-      dxcorner = case ptopLeft of-        [] -> assert `failure` (area, pl)-        l : _ -> T.length l-      (dx, dy) = assert (xwidth >= dxcorner && ywidth >= length ptopLeft-                         `blame` (area, pl))-                        (xwidth, ywidth)-      fromX (x2, y2) =-        zipWith (\x y -> Point x y) [x2..] (repeat y2)-      fillInterior :: (forall a. Int -> [a] -> [a]) -> [(Point, Char)]-      fillInterior f =-        let tileInterior (y, row) =-              let fx = f dx row-                  xStart = x0 + ((xwidth - length fx) `div` 2)-              in filter ((/= 'X') . snd) $ zip (fromX (xStart, y)) fx-            reflected =-              let fy = f dy $ map T.unpack ptopLeft-                  yStart = y0 + ((ywidth - length fy) `div` 2)-              in zip [yStart..] fy-        in concatMap tileInterior reflected-      tileReflect :: Int -> [a] -> [a]-      tileReflect d pat =-        let lstart = take (d `divUp` 2) pat-            lend   = take (d `div`   2) pat-        in lstart ++ reverse lend-      interior = case pcover of-        CAlternate ->-          let tile :: Int -> [a] -> [a]-              tile _ []  = assert `failure` "nothing to tile" `twith` pl-              tile d pat = take d (cycle $ init pat ++ init (reverse pat))-          in fillInterior tile-        CStretch ->-          let stretch :: Int -> [a] -> [a]-              stretch _ []  = assert `failure` "nothing to stretch" `twith` pl-              stretch d pat = tileReflect d (pat ++ repeat (last pat))-          in fillInterior stretch-        CReflect ->-          let reflect :: Int -> [a] -> [a]-              reflect d pat = tileReflect d (cycle pat)-          in fillInterior reflect-        CVerbatim -> fillInterior $ curry snd-  in EM.fromList interior--instance Binary Place where-  put Place{..} = do-    put qkind-    put qarea-    put qseen-    put qlegend-    put qsolidFence-    put qhollowFence-  get = do-    qkind <- get-    qarea <- get-    qseen <- get-    qlegend <- get-    qsolidFence <- get-    qhollowFence <- get-    return $! Place{..}
− Game/LambdaHack/Server/EndServer.hs 
@@ -1,95 +0,0 @@--- | The main loop of the server, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Server.EndServer-  ( endOrLoop, dieSer, dropEqpItems-  ) where--import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.State-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.HandleEffectServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State---- | Continue or exit or restart the game.-endOrLoop :: (MonadAtomic m, MonadServer m)-          => m () -> m () -> m () -> m () -> m ()-endOrLoop loop restart gameExit gameSave = do-  factionD <- getsState sfactionD-  let inGame fact = case gquit fact of-        Nothing -> True-        Just Status{stOutcome=Camping} -> True-        _ -> False-      gameOver = not $ any inGame $ EM.elems factionD-  let getQuitter fact = case gquit fact of-        Just Status{stOutcome=Restart, stInfo} -> Just stInfo-        _ -> Nothing-      quitters = mapMaybe getQuitter $ EM.elems factionD-  let isCamper fact = case gquit fact of-        Just Status{stOutcome=Camping} -> True-        _ -> False-      campers = filter (isCamper . snd) $ EM.assocs factionD-  -- Wipe out the quit flag for the savegame files.-  mapM_ (\(fid, fact) ->-            execUpdAtomic-            $ UpdQuitFaction fid Nothing (gquit fact) Nothing) campers-  bkpSave <- getsServer sbkpSave-  when bkpSave $ do-    modifyServer $ \ser -> ser {sbkpSave = False}-    gameSave-  case (quitters, campers) of-    (sgameMode : _, _) -> do-      modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}}-      restart-    _ | gameOver -> restart-    ([], []) -> loop  -- continue current game-    ([], _ : _) -> gameExit  -- don't call @loop@, that is, quit the game loop--dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m ()-dieSer aid b hit = do-  -- TODO: clients don't see the death of their last standing actor;-  --       modify Draw.hs and Client.hs to handle that-  if bproj b then do-    dropEqpItems aid b hit-    b2 <- getsState $ getActorBody aid-    execUpdAtomic $ UpdDestroyActor aid b2 []-  else do-    disco <- getsServer sdisco-    trunk <- getsState $ getItemBody $ btrunk b-    let ikind = disco EM.! jkindIx trunk-    execUpdAtomic $ UpdRecordKill aid ikind 1-    electLeader (bfid b) (blid b) aid-    equipAllItems aid b-    dropEqpItems aid b False-    b2 <- getsState $ getActorBody aid-    execUpdAtomic $ UpdDestroyActor aid b2 []-    deduceKilled b--equipAllItems :: (MonadAtomic m, MonadServer m)-              => ActorId -> Actor -> m ()-equipAllItems aid b = do-  fact <- getsState $ (EM.! bfid b) . sfactionD-  -- A faction that is defeated, leaderless or with temporarlity no member-  -- drops all items from the faction stash, too.-  when (isNothing $ gleader fact) $ moveStores aid CSha CEqp-  moveStores aid CInv CEqp---- | Drop all actor's items. If the actor hits another actor and this--- collision results in all item being dropped, all items are destroyed.--- If the actor does not hit, but dies, only fragile items are destroyed--- and only if the actor was a projectile (and so died by dropping--- to the ground due to exceeded range or bumping off an obstacle).-dropEqpItems :: (MonadAtomic m, MonadServer m)-             => ActorId -> Actor -> Bool -> m ()-dropEqpItems aid b hit = mapActorCStore_ CEqp (dropEqpItem aid b hit) b
− Game/LambdaHack/Server/Fov.hs 
@@ -1,231 +0,0 @@--- | Field Of View scanning with a variety of algorithms.--- See <https://github.com/LambdaHack/LambdaHack/wiki/Fov-and-los>--- for discussion.-module Game.LambdaHack.Server.Fov-  ( dungeonPerception, fidLidPerception-  , PersLit, litInDungeon-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumMap.Lazy as EML-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Function-import Data.List-import Data.Ord--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Server.Fov.Common-import qualified Game.LambdaHack.Server.Fov.Digital as Digital-import qualified Game.LambdaHack.Server.Fov.Permissive as Permissive-import qualified Game.LambdaHack.Server.Fov.Shadow as Shadow-import Game.LambdaHack.Server.State---- | Visually reachable position (light passes through them to the actor).-newtype PerceptionReachable = PerceptionReachable-    {preachable :: [Point]}-  deriving Show---- | All lit positions on a level.-newtype PerceptionLit = PerceptionLit-    {plit :: ES.EnumSet Point}-  deriving Show--type ActorEqpBody = [((ActorId, Actor), [ItemFull])]--type PersLit = EML.EnumMap LevelId ( PerceptionLit-                                   , EM.EnumMap FactionId ActorEqpBody )---- | Calculate faction's perception of a level.-levelPerception :: Kind.COps -> PerceptionLit -> ActorEqpBody-                -> FovMode -> Level-                -> Perception-levelPerception cops litHere actorEqpBody fovMode lvl@Level{lxsize, lysize} =-  let -- Dying actors included, to let them see their own demise.-      ours = filter (not . bproj . snd . fst) actorEqpBody-      ourR = preachable . reachableFromActor cops fovMode lvl-      totalReachable = PerceptionReachable $ concatMap ourR ours-      pAndVicinity p = p : vicinity lxsize lysize p-      -- All actors feel adjacent positions, even dark (for easy exploration).-      noctoBodies = map (\aEB@((_, b), _) -> (pAndVicinity (bpos b), aEB)) ours-      nocto = concat $ map fst noctoBodies-      ptotal = visibleOnLevel cops totalReachable litHere nocto lvl-      canSmellAround (_, allAssocs) =-        let radius = sumSlotNoFilter Effect.EqpSlotAddSmell allAssocs-        in radius >= 2-      -- TODO: handle smell radius < 2, that is only under the actor-      -- TODO: filter out tiles that are solid and so can't hold smell.-      psmell = PerceptionVisible $ ES.fromList-               $ concat $ map fst $ filter (canSmellAround . snd) noctoBodies-  in Perception ptotal psmell---- | Calculate faction's perception of a level based on the lit tiles cache..-fidLidPerception :: Kind.COps -> FovMode -> PersLit-                 -> FactionId -> LevelId -> Level-                 -> Perception-fidLidPerception cops fovMode persLit fid lid lvl =-  let (litHere, bodyMap) = persLit EML.! lid-      actorEqpBody = EM.findWithDefault [] fid bodyMap-  in levelPerception cops litHere actorEqpBody fovMode lvl---- | Calculate perception of a faction.-factionPerception :: FovMode -> PersLit -> FactionId -> State -> FactionPers-factionPerception fovMode persLit fid s =-  EM.mapWithKey (fidLidPerception (scops s) fovMode persLit fid) $ sdungeon s---- | Calculate the perception of the whole dungeon.-dungeonPerception :: FovMode -> State -> StateServer -> Pers-dungeonPerception fovMode s ser =-  let persLit = litInDungeon fovMode s ser-      f fid _ = factionPerception fovMode persLit fid s-  in EM.mapWithKey f $ sfactionD s---- | Compute positions visible (reachable and seen) by the party.--- A position can be directly lit by an ambient shine or by a weak, portable--- light source, e.g,, carried by an actor. A reachable and lit position--- is visible. Additionally, positions directly adjacent to an actor are--- assumed to be visible to him (through sound, touch, noctovision, whatever).-visibleOnLevel :: Kind.COps -> PerceptionReachable-               -> PerceptionLit -> [Point] -> Level-               -> PerceptionVisible-visibleOnLevel Kind.COps{cotile}-               PerceptionReachable{preachable} PerceptionLit{plit}-               nocto lvl =-  let isVisible pos = Tile.isLit cotile (lvl `at` pos) || pos `ES.member` plit-  in PerceptionVisible $ ES.fromList $ nocto ++ filter isVisible preachable---- | Compute positions reachable by the actor. Reachable are all fields--- on a visually unblocked path from the actor position.-reachableFromActor :: Kind.COps -> FovMode -> Level-                   -> ((ActorId, Actor), [ItemFull])-                   -> PerceptionReachable-reachableFromActor Kind.COps{cotile} fovMode lvl ((_, body), allItems) =-  let sumSight = sumSlotNoFilter Effect.EqpSlotAddSight allItems-      radius = min (fromIntegral $ bcalm body `div` (5 * oneM)) sumSight-  in PerceptionReachable $ fullscan cotile fovMode radius (bpos body) lvl---- | Compute all lit positions on a level, whether lit by actors or floor items.--- Note that an actor can be blind or a projectile, in which case he doesn't see--- his own light (but others, from his or other factions, possibly do).-litByItems :: Kind.COps -> FovMode -> Level-           -> [(Point, [ItemFull])]-           -> PerceptionLit-litByItems Kind.COps{cotile} fovMode lvl allItems =-  let litPos :: (Point, [ItemFull]) -> [Point]-      litPos (p, is) =-        let radius = sumSlotNoFilter Effect.EqpSlotAddLight is-            scan = fullscan cotile fovMode radius p lvl-            -- Optimization: filter out positions already having ambient light.-            opt = filter (\pos -> not $ Tile.isLit cotile $ lvl `at` pos) scan-        in opt-      litAll = concatMap litPos allItems-  in PerceptionLit $ ES.fromList litAll---- | Compute all lit positions in the dungeon-litInDungeon :: FovMode -> State -> StateServer -> PersLit-litInDungeon fovMode s ser =-  let cops = scops s-      itemsInActors :: Level -> EM.EnumMap FactionId ActorEqpBody-      itemsInActors lvl =-        let asLid = map (\aid -> (aid, getActorBody aid s))-                    $ concat $ EM.elems $ lprio lvl-            asGrouped = groupBy ((==) `on` (bfid . snd))-                        $ sortBy (comparing (bfid . snd)) asLid-            bodyFid :: [(ActorId, Actor)] -> (FactionId, ActorEqpBody)-            bodyFid [] = assert `failure` asGrouped-            bodyFid asFid@((_, bFid) : _) =-              let fid = bfid bFid-                  eqpBody (aid, b) =-                    ( (aid, b)-                    , map snd $ fullAssocs cops (sdisco ser) (sdiscoAE ser)-                                           aid [COrgan, CEqp] s )-              in (fid, map eqpBody asFid)-        in EM.fromDistinctAscList $ map bodyFid asGrouped-      itemsOnFloor :: Level -> [(Point, [ItemFull])]-      itemsOnFloor lvl =-        let iToFull (iid, (item, k)) =-              itemToFull cops (sdisco ser) (sdiscoAE ser) iid item k-            processPos (p, bag) =-              (p, map iToFull $ bagAssocsK s bag)-        in map processPos $ EM.assocs $ lfloor lvl-      -- Note that an actor can be blind or a projectile,-      -- in which case he doesn't see his own light-      -- (but others, from his or other factions, possibly do).-      litOnLevel :: Level -> ( PerceptionLit-                             , EM.EnumMap FactionId ActorEqpBody )-      litOnLevel lvl =-        let bodyMap = itemsInActors lvl-            allBodies = concat $ EM.elems bodyMap-            actorItems = map (\((_, b), iis) -> (bpos b, iis)) allBodies-            floorItems = itemsOnFloor lvl-            allItems = floorItems ++ actorItems-        in (litByItems cops fovMode lvl allItems, bodyMap)-      litLvl (lid, lvl) = (lid, litOnLevel lvl)-  in EML.fromDistinctAscList $ map litLvl $ EM.assocs $ sdungeon s---- | Perform a full scan for a given position. Returns the positions--- that are currently in the field of view. The Field of View--- algorithm to use is passed in the second argument.--- The actor's own position is considred reachable by him.-fullscan :: Kind.Ops TileKind  -- ^ tile content, determines clear tiles-         -> FovMode            -- ^ scanning mode-         -> Int                -- ^ scanning radius-         -> Point              -- ^ position of the spectator-         -> Level              -- ^ the map that is scanned-         -> [Point]-fullscan cotile fovMode radius spectatorPos lvl =-  if radius <= 0 then []-  else if radius == 1 then [spectatorPos]-  else spectatorPos : case fovMode of-    Shadow ->-      concatMap (\tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8-    Permissive ->-      concatMap (\tr -> map tr (Permissive.scan (isCl . tr))) tr4-    Digital ->-      concatMap (\tr -> map tr (Digital.scan (radius - 1) (isCl . tr))) tr4- where-  isCl :: Point -> Bool-  isCl = Tile.isClear cotile . (lvl `at`)--  -- This function is cheap, so no problem it's called twice-  -- for each point: once with @isCl@, once via @concatMap@.-  trV :: X -> Y -> Point-  {-# INLINE trV #-}-  trV x y = shift spectatorPos $ Vector x y--  -- | The translation, rotation and symmetry functions for octants.-  tr8 :: [(Distance, Progress) -> Point]-  tr8 =-    [ \(p, d) -> trV   p    d-    , \(p, d) -> trV (-p)   d-    , \(p, d) -> trV   p  (-d)-    , \(p, d) -> trV (-p) (-d)-    , \(p, d) -> trV   d    p-    , \(p, d) -> trV (-d)   p-    , \(p, d) -> trV   d  (-p)-    , \(p, d) -> trV (-d) (-p)-    ]--  -- | The translation and rotation functions for quadrants.-  tr4 :: [Bump -> Point]-  tr4 =-    [ \B{..} -> trV   bx  (-by)  -- quadrant I-    , \B{..} -> trV   by    bx   -- II (we rotate counter-clockwise)-    , \B{..} -> trV (-bx)   by   -- III-    , \B{..} -> trV (-by) (-bx)  -- IV-    ]
− Game/LambdaHack/Server/Fov/Common.hs 
@@ -1,73 +0,0 @@--- | Common definitions for the Field of View algorithms.--- See <https://github.com/LambdaHack/LambdaHack/wiki/Fov-and-los>--- for some more context and references.-module Game.LambdaHack.Server.Fov.Common-  ( -- * Current scan parameters-    Distance, Progress-    -- * Scanning coordinate system-  , Bump(..)-    -- * Geometry in system @Bump@-  , Line(..), ConvexHull, Edge, EdgeInterval-    -- * Assorted minor operations-  , maximal, steeper, addHull-  ) where--import Data.List---- | Distance from the (0, 0) point where FOV originates.-type Distance = Int--- | Progress along an arc with a constant distance from (0, 0).-type Progress = Int---- | Rotated and translated coordinates of 2D points, so that the points fit--- in a single quadrant area (e, g., quadrant I for Permissive FOV, hence both--- coordinates positive; adjacent diagonal halves of quadrant I and II--- for Digital FOV, hence y positive).--- The special coordinates are written using the standard mathematical--- coordinate setup, where quadrant I, with x and y positive,--- is on the upper right.-data Bump = B-  { bx :: !Int-  , by :: !Int-  }-  deriving Show---- | Straight line between points.-data Line = Line !Bump !Bump-  deriving Show---- | Convex hull represented as a list of points.-type ConvexHull   = [Bump]--- | An edge (comprising of a line and a convex hull)--- of the area to be scanned.-type Edge         = (Line, ConvexHull)--- | The area left to be scanned, delimited by edges.-type EdgeInterval = (Edge, Edge)---- | Maximal element of a non-empty list. Prefers elements from the rear,--- which is essential for PFOV, to avoid ill-defined lines.-maximal :: (a -> a -> Bool) -> [a] -> a-{-# INLINE maximal #-}-maximal gte = foldl1' (\acc e -> if gte e acc then e else acc)---- | Check if the line from the second point to the first is more steep--- than the line from the third point to the first. This is related--- to the formal notion of gradient (or angle), but hacked wrt signs--- to work fast in this particular setup. Returns True for ill-defined lines.-steeper :: Bump -> Bump -> Bump -> Bool-{-# INLINE steeper #-}-steeper (B xf yf) (B x1 y1) (B x2 y2) =-  (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1)---- | Extends a convex hull of bumps with a new bump. Nothing needs to be done--- if the new bump already lies within the hull. The first argument is--- typically `steeper`, optionally negated, applied to the second argument.-addHull :: (Bump -> Bump -> Bool)  -- ^ a comparison function-        -> Bump                    -- ^ a new bump to consider-        -> ConvexHull  -- ^ a convex hull of bumps represented as a list-        -> ConvexHull-{-# INLINE addHull #-}-addHull gte new = (new :) . go- where-  go (a:b:cs) | gte a b = go (b:cs)-  go l = l
− Game/LambdaHack/Server/Fov/Digital.hs 
@@ -1,153 +0,0 @@--- | DFOV (Digital Field of View) implemented according to specification at <http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation>.--- This fast version of the algorithm, based on "PFOV", has AFAIK--- never been described nor implemented before.-module Game.LambdaHack.Server.Fov.Digital-  ( scan, dline, dsteeper, intersect, debugSteeper, debugLine-  ) where--import Control.Exception.Assert.Sugar--import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Server.Fov.Common---- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0),--- within the given sight range.-scan :: Distance        -- ^ visiblity distance-     -> (Bump -> Bool)  -- ^ clear tile predicate-     -> [Bump]-scan r isClear = assert (r > 0 `blame` r) $-  -- The scanned area is a square, which is a sphere in the chessboard metric.-  dscan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0])-          , (Line (B 0 0) (B (r+1) r), [B 1 0]) )- where-  dscan :: Distance -> EdgeInterval -> [Bump]-  dscan d ( s0@(sl{-shallow line-}, sHull0)-          , e@(el{-steep line-}, eHull) ) =--    let ps0 = let (n, k) = intersect sl d  -- minimal progress to consider-              in n `div` k-        pe = let (n, k) = intersect el d   -- maximal progress to consider-               -- Corners obstruct view, so the steep line, constructed-               -- from corners, is itself not a part of the view,-               -- so if its intersection with the line of diagonals is only-               -- at a corner, choose the diamond leading to a smaller view.-             in -1 + n `divUp` k-        inside = [B p d | p <- [ps0..pe]]-        outside-          | d >= r = []-          | isClear (B ps0 d) = mscanVisible s0 (ps0+1)  -- start visible-          | otherwise = mscanShadowed (ps0+1)            -- start in shadow--        -- We're in a visible interval.-        mscanVisible :: Edge -> Progress -> [Bump]-        mscanVisible s@(_, sHull) ps-          | ps > pe = dscan (d+1) (s, e)       -- reached end, scan next-          | not $ isClear steepBump =          -- entering shadow-              mscanShadowed (ps+1)-              ++ dscan (d+1) (s, (dline nep steepBump, neHull))-          | otherwise = mscanVisible s (ps+1)  -- continue in visible area-         where-          steepBump = B ps d-          gte = dsteeper steepBump-          nep = maximal gte sHull-          neHull = addHull gte steepBump eHull--        -- We're in a shadowed interval.-        mscanShadowed :: Progress -> [Bump]-        mscanShadowed ps-          | ps > pe = []                       -- reached end while in shadow-          | isClear shallowBump =              -- moving out of shadow-              mscanVisible (dline nsp shallowBump, nsHull) (ps+1)-          | otherwise = mscanShadowed (ps+1)   -- continue in shadow-         where-          shallowBump = B ps d-          gte = flip $ dsteeper shallowBump-          nsp = maximal gte eHull-          nsHull = addHull gte shallowBump sHull0--    in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e,ps0,pe)) $-       inside ++ outside---- | Create a line from two points. Debug: check if well-defined.-dline :: Bump -> Bump -> Line-{-# INLINE dline #-}-dline p1 p2 =-  let line = Line p1 p2-  in assert (uncurry blame $ debugLine line) line---- | Compare steepness of @(p1, f)@ and @(p2, f)@.--- Debug: Verify that the results of 2 independent checks are equal.-dsteeper :: Bump -> Bump -> Bump -> Bool-{-# INLINE dsteeper #-}-dsteeper f p1 p2 =-  assert (res == debugSteeper f p1 p2) res- where res = steeper f p1 p2---- | The X coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of diamonds at distance--- @d@ from (0, 0).-intersect :: Line -> Distance -> (Int, Int)-{-# INLINE intersect #-}-intersect (Line (B x y) (B xf yf)) d =-  assert (allB (>= 0) [y, yf])-    ((d - y)*(xf - x) + x*(yf - y), yf - y)-{--Derivation of the formula:-The intersection point (xt, yt) satisfies the following equalities:-yt = d-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) = (xt - x) (yf - y)-(d - y) (xf - x) + x (yf - y) = xt (yf - y)-xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)--General remarks:-A diamond is denoted by its left corner. Hero at (0, 0).-Order of processing in the first quadrant rotated by 45 degrees is- 45678-  123-   @-so the first processed diamond is at (-1, 1). The order is similar-as for the restrictive shadow casting algorithm and reversed wrt PFOV.-The line in the curent state of mscan is called the shallow line,-but it's the one that delimits the view from the left, while the steep-line is on the right, opposite to PFOV. We start scanning from the left.--The Point coordinates are cartesian. The Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first (rotated 45 degrees) quadrant. The (Progress, Distance)-cordinates coincide with the Bump coordinates, unlike in PFOV.--}---- | Debug functions for DFOV:---- | Debug: calculate steeper for DFOV in another way and compare results.-debugSteeper :: Bump -> Bump -> Bump -> Bool-{-# INLINE debugSteeper #-}-debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) =-  assert (allB (>= 0) [yf, y1, y2]) $-  let (n1, k1) = intersect (Line p1 f) 0-      (n2, k2) = intersect (Line p2 f) 0-  in n1 * k2 >= k1 * n2---- | Debug: check if a view border line for DFOV is legal.-debugLine :: Line -> (Bool, String)-{-# INLINE debugLine #-}-debugLine line@(Line (B x1 y1) (B x2 y2))-  | not (allB (>= 0) [y1, y2]) =-      (False, "negative coordinates: " ++ show line)-  | y1 == y2 && x1 == x2 =-      (False, "ill-defined line: " ++ show line)-  | y1 == y2 =-      (False, "horizontal line: " ++ show line)-  | crossL0 =-      (False, "crosses the X axis below 0: " ++ show line)-  | crossG1 =-      (False, "crosses the X axis above 1: " ++ show line)-  | otherwise = (True, "")- where-  (n, k)  = line `intersect` 0-  (q, r)  = if k == 0 then (0, 0) else n `divMod` k-  crossL0 = q < 0  -- q truncated toward negative infinity-  crossG1 = q >= 1 && (q > 1 || r /= 0)
− Game/LambdaHack/Server/Fov/Permissive.hs 
@@ -1,156 +0,0 @@--- | PFOV (Permissive Field of View) clean-room reimplemented based on the algorithm described in <http://roguebasin.roguelikedevelopment.org/index.php?title=Precise_Permissive_Field_of_View>,--- though the general structure is more influenced by recursive shadow casting,--- as implemented in Shadow.hs. In the result, this algorithm is much faster--- than the original algorithm on dense maps, since it does not scan--- areas blocked by shadows.-module Game.LambdaHack.Server.Fov.Permissive-  ( scan, dline, dsteeper, intersect, debugSteeper, debugLine-  ) where--import Control.Exception.Assert.Sugar--import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Server.Fov.Common---- TODO: Scanning squares on horizontal lines in octants, not squares--- on diagonals in quadrants, may be much faster and a bit simpler.--- Right now we build new view on each end of each visible wall tile--- and this is necessary only for straight, thin, diagonal walls.---- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0).-scan :: (Bump -> Bool)  -- ^ clear tile predicate-     -> [Bump]-scan isClear =-  dscan 1 ( (Line (B 0 1) (B 999 0), [B 1 0])-          , (Line (B 1 0) (B 0 999), [B 0 1]) )- where-  dscan :: Distance -> EdgeInterval -> [Bump]-  dscan d ( s0@(sl{-shallow line-}, sHull0)-          , e@(el{-steep line-}, eHull) ) =-    assert (d >= 0 && pe + 1 >= ps0 && ps0 >= 0-            `blame` (d,s0,e,ps0,pe)) $-    if illegal then [] else inside ++ outside-   where-    (ns, ks) = sl `intersect` d-    (ne, ke) = el `intersect` d-    -- Corners are translucent, so they are invisible, so if intersection-    -- is at a corner, choose pe that creates the smaller view.-    (ps0, pe) = (ns `div` ks, ne `divUp` ke - 1)  -- progress interval to check-    -- A single ray from an extremity produces non-permissive digital lines.-    illegal  = let (n, k) = intersect sl 0-               in ns*ke == ne*ks && (n `elem` [0, k])-    pd2bump     (p, di) = B (di - p) p-    bottomRight (p, di) = B (di - p + 1) p--    inside = [pd2bump (p, d) | p <- [ps0..pe]]-    outside-      | isClear (pd2bump (ps0, d)) = mscanVisible s0 ps0  -- start visible-      | ps0 == ns `divUp` ks = mscanVisible s0 ps0        -- start in a corner-      | otherwise = mscanShadowed (ps0+1)                 -- start in mid-wall--    -- We're in a visible interval.-    mscanVisible :: Edge -> Progress -> [Bump]-    mscanVisible s@(_, sHull) ps-      | ps > pe = dscan (d+1) (s, e)           -- reached end, scan next-      | not $ isClear (pd2bump (ps, d)) =      -- enter shadow, steep bump-          let steepBump = bottomRight (ps, d)-              gte = flip $ dsteeper steepBump-              -- sHull may contain steepBump, but maximal will ignore it-              nep = maximal gte sHull-              neHull = addHull gte steepBump eHull-          in mscanShadowed (ps+1)-             ++ dscan (d+1) (s, (dline nep steepBump, neHull))-      | otherwise = mscanVisible s (ps+1)      -- continue in visible area--    -- we're in a shadowed interval.-    mscanShadowed :: Progress -> [Bump]-    mscanShadowed ps-      | ps > ne `div` ke = []                  -- reached absolute end-      | otherwise =                            -- out of shadow, shallow bump-          -- the ray can just pass through a corner of diagonal walls-          -- and the recursive call verifies that at the same ps coordinate-          let shallowBump = bottomRight (ps, d)-              gte = dsteeper shallowBump-              nsp = maximal gte eHull-              nsHull = addHull gte shallowBump sHull0-          in mscanVisible (dline nsp shallowBump, nsHull) ps---- | Create a line from two points. Debug: check if well-defined.-dline :: Bump -> Bump -> Line-dline p1 p2 =-  let line = Line p1 p2-  in assert (uncurry blame $ debugLine line) line---- | Compare steepness of @(p1, f)@ and @(p2, f)@.--- Debug: Verify that the results of 2 independent checks are equal.-dsteeper :: Bump -> Bump -> Bump -> Bool-dsteeper f p1 p2 =-  assert (res == debugSteeper f p1 p2) res- where res = steeper f p1 p2---- | The Y coordinate, represented as a fraction, of the intersection of--- a given line and the line of diagonals of squares at distance--- @d@ from (0, 0).-intersect :: Line -> Distance -> (Int, Int)-intersect (Line (B x y) (B xf yf)) d =-  assert (allB (>= 0) [x, y, xf, yf])-    ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y))-{--Derivation of the formula:-The intersection point (xt, yt) satisfies the following equalities:-xt = 1 + d - yt-(yt - y) (xf - x) = (xt - x) (yf - y)-hence-(yt - y) (xf - x) = (xt - x) (yf - y)-yt (xf - x) - y xf = xt (yf - y) - x yf-yt (xf - x) - y xf = (1 + d) (yf - y) - yt (yf - y) - x yf-yt (xf - x) + yt (yf - y) = (1 + d) (yf - y) - x yf + y xf-yt = ((1 + d) (yf - y) + y xf - x yf) / (xf - x + yf - y)--General remarks:-A square is denoted by its bottom-left corner. Hero at (0, 0).-Order of processing in the first quadrant is-9-58-247-@136-so the first processed square is at (0, 1). The order is reversed-wrt the restrictive shadow casting algorithm. The line in the curent state-of mscan is not the steep line, but the shallow line,-and we start scanning from the bottom right.--The Point coordinates are cartesian. The Bump coordinates are cartesian,-translated so that the hero is at (0, 0) and rotated so that he always-looks at the first quadrant. The (Progress, Distance) cordinates-are mangled and not used for geometry.--}---- | Debug functions for PFOV:---- | Debug: calculate steeper for PFOV in another way and compare results.-debugSteeper :: Bump -> Bump -> Bump -> Bool-debugSteeper f@(B xf yf) p1@(B x1 y1) p2@(B x2 y2) =-  assert (allB (>= 0) [xf, yf, x1, y1, x2, y2]) $-  let (n1, k1) = intersect (Line p1 f) 0-      (n2, k2) = intersect (Line p2 f) 0-  in n1 * k2 <= k1 * n2---- | Debug: checks postconditions of borderLine.-debugLine :: Line -> (Bool, String)-debugLine line@(Line (B x1 y1) (B x2 y2))-  | not (allB (>= 0) [x1, y1, x2, y2]) =-      (False, "negative coordinates: " ++ show line)-  | y1 == y2 && x1 == x2 =-      (False, "ill-defined line: " ++ show line)-  | x2 - x1 == - (y2 - y1) =-      (False, "diagonal line: " ++ show line)-  | crossL0 =-      (False, "crosses diagonal below 0: " ++ show line)-  | crossG1 =-      (False, "crosses diagonal above 1: " ++ show line)-  | otherwise = (True, "")- where-  (n, k)  = line `intersect` 0-  (q, r)  = if k == 0 then (0, 0) else n `divMod` k-  crossL0 = q < 0  -- q truncated toward negative infinity-  crossG1 = q >= 1 && (q > 1 || r /= 0)
− Game/LambdaHack/Server/Fov/Shadow.hs 
@@ -1,111 +0,0 @@--- | A restrictive variant of Recursive Shadow Casting FOV with infinite range.--- It's not designed for dungeons with diagonal walls and so here--- they block visibility, though they don't block movement.--- The main advantage of the algorithm is that it's very simple and fast.-module Game.LambdaHack.Server.Fov.Shadow (SBump, Interval, scan) where--import Control.Exception.Assert.Sugar-import Data.Ratio--import Game.LambdaHack.Server.Fov.Common--{--Field Of View----------------The algorithm used is a variant of Shadow Casting. We first compute-fields that are reachable (have unobstructed line of sight) from the hero's-position. Later, in Perception.hs, from this information we compute-the fields that are visible (not hidden in darkness, etc.).--As input to the algorithm, we require information about fields that-block light. As output, we get information on the reachability of all fields.-We assume that the hero is located at position (0, 0)-and we only consider fields (line, row) where line >= 0 and 0 <= row <= line.-This is just about one eighth of the whole hero's surroundings,-but the other parts can be computed in the same fashion by mirroring-or rotating the given algorithm accordingly.--      fov (blocks, maxline) =-         shadow := \empty_set-         reachable (0, 0) := True-         for l \in [ 1 .. maxline ] do-            for r \in [ 0 .. l ] do-              reachable (l, r) := ( \exists a. a \in interval (l, r) \and-                                    a \not_in shadow)-              if blocks (l, r) then-                 shadow := shadow \union interval (l, r)-              end if-            end for-         end for-         return reachable--      interval (l, r) = return [ angle (l + 0.5, r - 0.5),-                                 angle (l - 0.5, r + 0.5) ]-      angle (l, r) = return atan (r / l)--The algorithm traverses the fields line by line, row by row.-At every moment, we keep in shadow the intervals which are in shadow,-measured by their angle. A square is reachable when any point-in it is not in shadow --- the algorithm is permissive in this respect.-We could also require that a certain fraction of the field is reachable,-or a specific point. Our choice has certain consequences. For instance,-a single blocking field throws a shadow, but the fields immediately behind-the blocking field are still visible.--We can compute the interval of angles corresponding to one square field-by computing the angle of the line passing the upper left corner-and the angle of the line passing the lower right corner.-This is what interval and angle do. If a field is blocking, the interval-for the square is added to the shadow set.--}---- | Rotated and translated coordinates of 2D points, so that they fit--- in the same single octant area.-type SBump = (Progress, Distance)---- | The area left to be scanned, delimited by fractions of the original arc.--- Interval @(0, 1)@ means the whole 45 degrees arc of the processed octant--- is to be scanned.-type Interval = (Rational, Rational)---- TODO: if ever used, apply static argument transformation to isClear.--- | Calculates the list of tiles, in @SBump@ coordinates, visible from (0, 0).-scan :: (SBump -> Bool)  -- ^ clear tile predicate-     -> Distance         -- ^ the current distance from (0, 0)-     -> Interval         -- ^ the current interval to scan-     -> [SBump]-scan isClear d (s0, e) =-  let ps = downBias (s0 * fromIntegral d)   -- minimal progress to consider-      pe = upBias (e * fromIntegral d)      -- maximal progress to consider-      inside = [(p, d) | p <- [ps..pe]]-      outside-        | isClear (ps, d) = mscan (Just s0) ps pe  -- start in light-        | otherwise = mscan Nothing ps pe          -- start in shadow-  in assert (d >= 0 && e >= 0 && s0 >= 0 && pe >= ps && ps >= 0-             `blame` (d,s0,e,ps,pe)) $-     inside ++ outside- where-  -- The current state of a scan is kept in @Maybe Rational@.-  -- If it's the @Just@ case, we're in a visible interval. If @Nothing@,-  -- we're in a shadowed interval.-  mscan :: Maybe Rational -> Progress -> Progress -> [SBump]-  mscan (Just s) ps pe-    | s >= e = []                           -- empty interval-    | ps > pe  = scan isClear (d+1) (s, e)  -- reached end, scan next-    | not $ isClear (ps, d) =               -- entering shadow-        let ne = (fromIntegral ps - (1%2)) / (fromIntegral d + (1%2))-        in mscan Nothing (ps+1) pe ++ scan isClear (d+1) (s, ne)-    | otherwise = mscan (Just s) (ps+1) pe  -- continue in light--  mscan Nothing ps pe-    | ps > pe = []                          -- reached end while in shadow-    | isClear (ps, d) =                     -- moving out of shadow-        let ns = (fromIntegral ps - (1%2)) / (fromIntegral d - (1%2))-        in mscan (Just ns) (ps+1) pe-    | otherwise = mscan Nothing (ps+1) pe   -- continue in shadow---downBias, upBias :: (Integral a, Integral b) => Ratio a -> b-downBias x = round (x - 1 % (denominator x * 3))-upBias   x = round (x + 1 % (denominator x * 3))
− Game/LambdaHack/Server/HandleEffectServer.hs 
@@ -1,817 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Handle effects (most often caused by requests sent by clients).-module Game.LambdaHack.Server.HandleEffectServer-  ( applyItem, itemEffect, itemEffectAndDestroy, effectsSem-  , dropEqpItem, armorHurtBonus-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Bits (xor)-import qualified Data.EnumMap.Strict as EM-import Data.Key (mapWithKeyM_)-import Data.Maybe-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.PeriodicServer-import Game.LambdaHack.Server.StartServer-import Game.LambdaHack.Server.State---- + Semantics of effects--applyItem :: (MonadAtomic m, MonadServer m)-          => ActorId -> ItemId -> CStore -> m ()-applyItem aid iid cstore = do-  itemToF <- itemToFullServer-  bag <- getsState $ getActorBag aid cstore-  let k = bag EM.! iid-      itemFull = itemToF iid k-  execSfxAtomic $ SfxActivate aid iid 1-  itemEffectAndDestroy aid aid iid itemFull cstore--itemEffectAndDestroy :: (MonadAtomic m, MonadServer m)-                     => ActorId -> ActorId -> ItemId -> ItemFull -> CStore-                     -> m ()-itemEffectAndDestroy source target iid itemFull cstore = do-  -- We have to destroy the item before the effect affects the item-  -- or the actor holding it or standing on it (later on we could-  -- lose track of the item and wouldn't be able to destroy it) .-  -- This is OK, because we don't remove the item type from various-  -- item dictionaries, just an individual copy from the container,-  -- so, e.g., the item can be identified after it's removed.-  let item = itemBase itemFull-      durable = Effect.Durable `elem` jfeature item-      periodic = isJust $ strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull-      c = CActor source cstore-  unless (durable && periodic) $ do-    when (not durable) $-      execUpdAtomic $ UpdLoseItem iid item 1 c-    triggered <- itemEffect source target iid itemFull False False-    -- If none of item's effects was performed, we try to recreate the item.-    -- Regardless, we don't rewind the time, because some info is gained-    -- (that the item does not exhibit any effects in the given context).-    when (not triggered && not durable) $-      execUpdAtomic $ UpdSpotItem iid item 1 c---- | The source actor affects the target actor, with a given item.--- If any of the effect effect fires up, the item gets identified. This function--- is mutually recursive with @effect@ and so it's a part of @Effect@--- semantics.-itemEffect :: (MonadAtomic m, MonadServer m)-           => ActorId -> ActorId -> ItemId -> ItemFull -> Bool -> Bool-           -> m Bool-itemEffect source target iid itemFull onSmash periodic = do-  case itemDisco itemFull of-    Just ItemDisco{itemKindId, itemAE=Just ItemAspectEffect{jeffects}} -> do-      let effs | onSmash = strengthOnSmash itemFull-               | otherwise = jeffects-      triggered <- effectsSem effs source target periodic-      -- The effect fires up, so the item gets identified, if seen-      -- (the item was at the source actor's position, so his old position-      -- is given, since the actor and/or the item may be moved by the effect;-      -- we'd need to track not only position of atomic commands and factions,-      -- but also which items they relate to, to be fully accurate).-      when triggered $ do-        postb <- getsState $ getActorBody source-        seed <- getsServer $ (EM.! iid) . sitemSeedD-        execUpdAtomic $ UpdDiscover (blid postb) (bpos postb)-                                    iid itemKindId seed-      return triggered-    _ -> assert `failure` (source, target, iid, itemFull)--effectsSem :: (MonadAtomic m, MonadServer m)-           => [Effect.Effect Int] -> ActorId -> ActorId -> Bool-           -> m Bool-effectsSem effects source target periodic = do-  trs <- mapM (\ef -> effectSem ef source target) effects-  let triggered = or trs-  sb <- getsState $ getActorBody source-  -- Announce no effect, which is rare and wastes time, so noteworthy.-  unless (triggered  -- some effect triggered, so feedback comes from them-          || null effects  -- no effects present, no feedback needed-          || periodic  -- don't spam from fizzled periodic effects-          || bproj sb) $  -- don't spam, projectiles can be very numerous-    execSfxAtomic $ SfxEffect (bfid sb) target $ Effect.NoEffect ""-  return triggered---- | The source actor affects the target actor, with a given effect and power.--- Both actors are on the current level and can be the same actor.--- The boolean result indicates if the effect actually fired up,--- as opposed to fizzled.-effectSem :: (MonadAtomic m, MonadServer m)-          => Effect.Effect Int -> ActorId -> ActorId-          -> m Bool-effectSem effect source target = do-  sb <- getsState $ getActorBody source-  -- @execSfx@ usually comes last in effect semantics, but not always-  -- and we are likely to introduce more variety.-  let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect-  case effect of-    Effect.NoEffect _ -> return False-    Effect.RefillHP p -> effectRefillHP execSfx p source target-    Effect.Hurt nDm -> effectHurt nDm source target-    Effect.RefillCalm p -> effectRefillCalm execSfx p target-    Effect.Dominate -> effectDominate source target-    Effect.Impress -> effectImpress execSfx source target-    Effect.CallFriend p -> effectCallFriend p source target-    Effect.Summon freqs p -> effectSummon freqs p source target-    Effect.CreateItem p -> effectCreateItem p target-    Effect.ApplyPerfume -> effectApplyPerfume execSfx target-    Effect.Burn p -> effectBurn execSfx p source target-    Effect.Ascend p -> effectAscend execSfx p source target-    Effect.Escape{} -> effectEscape target-    Effect.Paralyze p -> effectParalyze execSfx p target-    Effect.InsertMove p -> effectInsertMove execSfx p target-    Effect.DropBestWeapon -> effectDropBestWeapon execSfx target-    Effect.DropEqp symbol hit -> effectDropEqp execSfx hit target symbol-    Effect.SendFlying tmod ->-      effectSendFlying execSfx tmod source target Nothing-    Effect.PushActor tmod ->-      effectSendFlying execSfx tmod source target (Just True)-    Effect.PullActor tmod ->-      effectSendFlying execSfx tmod source target (Just False)-    Effect.Teleport p -> effectTeleport execSfx p target-    Effect.PolyItem cstore -> effectPolyItem execSfx cstore target-    Effect.Identify cstore -> effectIdentify execSfx cstore target-    Effect.ActivateInv symbol -> effectActivateInv execSfx target symbol-    Effect.Explode t -> effectExplode execSfx t target-    Effect.OneOf l -> effectOneOf l source target-    Effect.OnSmash _ -> return False  -- ignored under normal circumstances-    Effect.TimedAspect{} -> return False  -- TODO---- + Individual semantic functions for effects---- ** RefillHP--effectRefillHP :: (MonadAtomic m, MonadServer m)-           => m () -> Int -> ActorId -> ActorId -> m Bool-effectRefillHP execSfx power source target = do-  tb <- getsState $ getActorBody target-  hpMax <- sumOrganEqpServer Effect.EqpSlotAddMaxHP target-  let deltaHP = min (xM power) (max 0 $ xM hpMax - bhp tb)-  if deltaHP == 0-    then return False-    else do-      execUpdAtomic $ UpdRefillHP target deltaHP-      when (deltaHP < 0 && source /= target && not (bproj tb)) $-        halveCalm target-      execSfx-      return True--halveCalm :: (MonadAtomic m, MonadServer m)-          => ActorId -> m ()-halveCalm target = do-  tb <- getsState $ getActorBody target-  activeItems <- activeItemsServer target-  let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems-      calmUpperBound = if hpTooLow tb activeItems-                       then 0  -- to trigger domination, etc.-                       else xM calmMax `div` 2-      deltaCalm = min minusTwoM (calmUpperBound - bcalm tb)-  -- HP loss decreases Calm by at least minusTwoM, to overcome Calm regen,-  -- when far from shooting foe and to avoid "hears something",-  -- which is emitted for decrease minusM.-  execUpdAtomic $ UpdRefillCalm target deltaCalm---- ** Hurt--effectHurt :: (MonadAtomic m, MonadServer m)-           => Dice.Dice -> ActorId -> ActorId-           -> m Bool-effectHurt nDm source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm-  hurtBonus <- armorHurtBonus source target-  let block = braced tb-      mult = (100 + hurtBonus) * (if block then 50 else 100)-      deltaHP = - (max oneM  -- at least 1 HP taken-                   $ fromIntegral mult * xM n `divUp` (100 * 100))-      deltaDiv = fromIntegral $ deltaHP `divUp` oneM-  -- Damage the target.-  execUpdAtomic $ UpdRefillHP target deltaHP-  when (source /= target && not (bproj tb)) $ halveCalm target-  execSfxAtomic $ SfxEffect (bfid sb) target $-    if source == target-    then Effect.RefillHP deltaDiv  -- no SfxStrike, so treat as any heal/wound-    else Effect.Hurt (Dice.intToDice deltaDiv)  -- avoid spam; SfxStrike sent-  return True--armorHurtBonus :: (MonadAtomic m, MonadServer m)-               => ActorId -> ActorId-               -> m Int-armorHurtBonus source target = do-  sactiveItems <- activeItemsServer source-  tactiveItems <- activeItemsServer target-  sb <- getsState $ getActorBody source-  return $! if bproj sb-            then sumSlotNoFilter Effect.EqpSlotAddHurtRanged sactiveItems-                 - sumSlotNoFilter Effect.EqpSlotAddArmorRanged tactiveItems-            else sumSlotNoFilter Effect.EqpSlotAddHurtMelee sactiveItems-                 - sumSlotNoFilter Effect.EqpSlotAddArmorMelee tactiveItems---- ** RefillCalm--effectRefillCalm ::  (MonadAtomic m, MonadServer m)-           => m () -> Int -> ActorId -> m Bool-effectRefillCalm execSfx power target = do-  tb <- getsState $ getActorBody target-  calmMax <- sumOrganEqpServer Effect.EqpSlotAddMaxCalm target-  let deltaCalm = min (xM power) (max 0 $ xM calmMax - bcalm tb)-  if deltaCalm == 0-    then return False-    else do-      execUpdAtomic $ UpdRefillCalm target deltaCalm-      execSfx-      return True---- ** Dominate--effectDominate :: (MonadAtomic m, MonadServer m)-               => ActorId -> ActorId -> m Bool-effectDominate source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  if bproj tb then-    return False-  else if bfid tb == bfid sb then-    effectSem Effect.Impress source target-  else-    dominateFidSfx (bfid sb) target---- ** Impress--effectImpress :: (MonadAtomic m, MonadServer m)-              => m () -> ActorId -> ActorId -> m Bool-effectImpress execSfx source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  if boldfid tb == bfid sb || bproj tb then-    return False-  else do-    execSfx-    execUpdAtomic $ UpdOldFidActor target (boldfid tb) (bfid sb)-    return True---- ** SummonFriend--effectCallFriend :: (MonadAtomic m, MonadServer m)-                   => Int -> ActorId -> ActorId-                   -> m Bool-effectCallFriend power source target = assert (power > 0) $ do-  -- Obvious effect, nothing announced.-  Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  activeItems <- activeItemsServer source-  let legal = source == target-              && hpEnough sb activeItems-              && bhp sb >= xM 10  -- prevent spam from regenerating wimps-  if not legal then return False-  else do-    let hpMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-        deltaHP = - xM hpMax `div` 3-    execUpdAtomic $ UpdRefillHP source deltaHP-    let validTile t = not $ Tile.hasFeature cotile F.NoActor t-        lid = blid sb-    ps <- getsState $ nearbyFreePoints validTile (bpos sb) lid-    time <- getsState $ getLocalTime lid-    recruitActors (take power ps) lid time (bfid sb)---- ** Summon--effectSummon :: (MonadAtomic m, MonadServer m)-             => Freqs -> Int -> ActorId -> ActorId -> m Bool-effectSummon actorFreq power source target = assert (power > 0) $ do-  -- Obvious effect, nothing announced.-  Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  activeItems <- activeItemsServer source-  let legal = source == target-              && (bproj sb-                  || calmEnough sb activeItems-                     && bcalm sb >= xM 10)-  if not legal then return False-  else do-    let calmMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems-        deltaCalm = - xM calmMax `div` 3-    unless (bproj sb) $ execUpdAtomic $ UpdRefillCalm source deltaCalm-    let validTile t = not $ Tile.hasFeature cotile F.NoActor t-    ps <- getsState $ nearbyFreePoints validTile (bpos sb) (blid sb)-    localTime <- getsState $ getLocalTime (blid sb)-    -- Make sure summoned actors start acting after the summoner.-    let sourceTime = timeShift localTime $ ticksPerMeter $ bspeed sb activeItems-        afterTime = timeShift sourceTime $ Delta timeClip-    bs <- forM (take power ps) $ \p -> do-      maid <- addAnyActor actorFreq (blid sb) afterTime (Just p)-      case maid of-        Nothing ->-          -- Don't make this item useless.-          effectSem (Effect.CallFriend 1) source target-        Just aid -> do-          b <- getsState $ getActorBody aid-          mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD-          when (isNothing mleader) $-            execUpdAtomic $ UpdLeadFaction (bfid b) Nothing (Just aid)-          return True-    return $! or bs---- ** CreateItem--effectCreateItem :: (MonadAtomic m, MonadServer m)-                 => Int -> ActorId -> m Bool-effectCreateItem power target = assert (power > 0) $ do-  -- Obvious effect, nothing announced.-  tb <- getsState $ getActorBody target-  void $ createItems power (bpos tb) (blid tb)-  return True---- ** ApplyPerfume--effectApplyPerfume :: (MonadAtomic m, MonadServer m)-                   => m () -> ActorId -> m Bool-effectApplyPerfume execSfx target = do-  tb <- getsState $ getActorBody target-  Level{lsmell} <- getLevel $ blid tb-  let f p fromSm =-        execUpdAtomic $ UpdAlterSmell (blid tb) p (Just fromSm) Nothing-  mapWithKeyM_ f lsmell-  execSfx-  return True---- ** Burn--effectBurn :: (MonadAtomic m, MonadServer m)-           => m () -> Int -> ActorId -> ActorId-           -> m Bool-effectBurn execSfx power source target = do-  -- Damage from both impact and fire.-  void $ effectHurt (Dice.intToDice $ 2 * power) source target-  execSfx-  return True---- ** Ascend---- Note that projectiles can be teleported, too, for extra fun.-effectAscend :: (MonadAtomic m, MonadServer m)-             => m () -> Int -> ActorId -> ActorId -> m Bool-effectAscend execSfx k source aid = do-  b1 <- getsState $ getActorBody aid-  ais1 <- getsState $ getCarriedAssocs b1-  let lid1 = blid b1-      pos1 = bpos b1-  (lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon-  if lid2 == lid1 && pos2 == pos1 then do-    execSfxAtomic $ SfxMsgFid (bfid b1) "No more levels in this direction."-    let effect = Effect.Teleport 30  -- powerful teleport-    effectSem effect source aid-  else do-    let switch1 = void $ switchLevels1 ((aid, b1), ais1)-        switch2 = do-          -- Make the intiator of the stair move the leader,-          -- to let him clear the stairs for other to follow.-          let mlead = Just aid-          -- Move the actor to where the inhabitants were, if any.-          switchLevels2 lid2 pos2 ((aid, b1), ais1) mlead-          -- Verify only one non-projectile actor on every tile.-          !_ <- getsState $ posToActors pos1 lid1  -- assertion is inside-          !_ <- getsState $ posToActors pos2 lid2  -- assertion is inside-          return ()-    -- The actor will be added to the new level, but there can be other actors-    -- at his new position.-    inhabitants <- getsState $ posToActors pos2 lid2-    case inhabitants of-      [] -> do-        switch1-        switch2-      ((_, b2), _) : _ -> do-        -- Alert about the switch.-        let subjects = map (partActor . snd . fst) inhabitants-            subject = MU.WWandW subjects-            verb = "be pushed to another level"-            msg2 = makeSentence [MU.SubjectVerbSg subject verb]-        -- Only tell one player, even if many actors, because then-        -- they are projectiles, so not too important.-        execSfxAtomic $ SfxMsgFid (bfid b2) msg2-        -- Move the actor out of the way.-        switch1-        -- Move the inhabitant out of the way and to where the actor was.-        let moveInh inh = do-              -- Preserve old the leader, since the actor is pushed, so possibly-              -- has nothing worhwhile to do on the new level (and could try-              -- to switch back, if made a leader, leading to a loop).-              inhMLead <- switchLevels1 inh-              switchLevels2 lid1 pos1 inh inhMLead-        mapM_ moveInh inhabitants-        -- Move the actor to his destination.-        switch2-    execSfx-    return True--switchLevels1 :: MonadAtomic m-              => ((ActorId, Actor), [(ItemId, Item)]) -> m (Maybe ActorId)-switchLevels1 ((aid, bOld), ais) = do-  let side = bfid bOld-  mleader <- getsState $ gleader . (EM.! side) . sfactionD-  -- Prevent leader pointing to a non-existing actor.-  mlead <--    if not (bproj bOld) && isJust mleader then do-      execUpdAtomic $ UpdLeadFaction side mleader Nothing-      return mleader-    else return Nothing-  -- Remove the actor from the old level.-  -- Onlookers see somebody disappear suddenly.-  -- @UpdDestroyActor@ is too loud, so use @UpdLoseActor@ instead.-  execUpdAtomic $ UpdLoseActor aid bOld ais-  return mlead--switchLevels2 :: MonadAtomic m-              => LevelId -> Point-              -> ((ActorId, Actor), [(ItemId, Item)]) -> Maybe ActorId-              -> m ()-switchLevels2 lidNew posNew ((aid, bOld), ais) mlead = do-  let lidOld = blid bOld-      side = bfid bOld-  assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip-  -- Sync the actor time with the level time.-  timeOld <- getsState $ getLocalTime lidOld-  timeLastVisited <- getsState $ getLocalTime lidNew-  -- This time calculation may cause a double move of a foe of the same-  -- speed, but this is OK --- the foe didn't have a chance to move-  -- before, because the arena went inactive, so he moves now one more time.-  let delta = btime bOld `timeDeltaToFrom` timeOld-      bNew = bOld { blid = lidNew-                  , btime = timeShift timeLastVisited delta-                  , bpos = posNew-                  , boldpos = posNew  -- new level, new direction-                  , boldlid = lidOld }  -- record old level-  -- Materialize the actor at the new location.-  -- Onlookers see somebody appear suddenly. The actor himself-  -- sees new surroundings and has to reset his perception.-  execUpdAtomic $ UpdCreateActor aid bNew ais-  when (isJust mlead) $ execUpdAtomic $ UpdLeadFaction side Nothing mlead---- ** Escape---- | The faction leaves the dungeon.-effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool-effectEscape target = do-  -- Obvious effect, nothing announced.-  b <- getsState $ getActorBody target-  let fid = bfid b-  fact <- getsState $ (EM.! fid) . sfactionD-  if not (keepArenaFact fact) || bproj b then-    return False-  else do-    deduceQuits b $ Status Escape (fromEnum $ blid b) ""-    return True---- ** Paralyze---- | Advance target actor time by this many time clips. Not by actor moves,--- to hurt fast actors more.-effectParalyze :: (MonadAtomic m, MonadServer m)-               => m () -> Int -> ActorId -> m Bool-effectParalyze execSfx p target = assert (p > 0) $ do-  b <- getsState $ getActorBody target-  if bproj b || bhp b <= 0-    then return False-    else do-      let t = timeDeltaScale (Delta timeClip) p-      execUpdAtomic $ UpdAgeActor target t-      execSfx-      return True---- ** InsertMove---- TODO: Replace with SpeedBurst that lasts just 1 turn,--- but make sure the cost of this item activation is vs previous speed--- | Give target actor the given number of extra moves. Don't give--- an absolute amount of time units, to benefit slow actors more.-effectInsertMove :: (MonadAtomic m, MonadServer m)-                 => m () -> Int -> ActorId -> m Bool-effectInsertMove execSfx p target = assert (p > 0) $ do-  b <- getsState $ getActorBody target-  activeItems <- activeItemsServer target-  let tpm = ticksPerMeter $ bspeed b activeItems-      t = timeDeltaScale tpm (-p)-  execUpdAtomic $ UpdAgeActor target t-  execSfx-  return True---- ** DropBestWeapon---- | Make the target actor drop his best weapon (stack).-effectDropBestWeapon :: (MonadAtomic m, MonadServer m)-                     => m () -> ActorId -> m Bool-effectDropBestWeapon execSfx target = do-  allAssocs <- fullAssocsServer target [CEqp]-  case strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of-    (_, (iid, _)) : _ -> do-      b <- getsState $ getActorBody target-      let k = beqp b EM.! iid-      dropEqpItem target b False iid k-      execSfx-      return True-    [] ->-      return False---- | Drop a single actor's item. Note that if there multiple copies,--- at most one explodes to avoid excessive carnage and UI clutter--- (let's say, the multiple explosions interfere with each other or perhaps--- larger quantities of explosives tend to be packaged more safely).-dropEqpItem :: (MonadAtomic m, MonadServer m)-            => ActorId -> Actor -> Bool -> ItemId -> Int -> m ()-dropEqpItem aid b hit iid k = do-  item <- getsState $ getItemBody iid-  itemToF <- itemToFullServer-  let container = CActor aid CEqp-      fragile = Effect.Fragile `elem` jfeature item-      durable = Effect.Durable `elem` jfeature item-      isDestroyed = hit && not durable || bproj b && fragile-      itemFull = itemToF iid k-  if isDestroyed then do-    -- Feedback from hit, or it's shrapnel, so no @UpdDestroyItem@.-    execUpdAtomic $ UpdLoseItem iid item k container-    void $ itemEffect aid aid iid itemFull True False-  else do-    mvCmd <- generalMoveItem iid k (CActor aid CEqp)-                                   (CActor aid CGround)-    mapM_ execUpdAtomic mvCmd---- ** DropEqp---- | Make the target actor drop all items in his equiment with the given symbol--- (not just a random one, or cluttering equipment with rubbish--- would be beneficial).-effectDropEqp :: (MonadAtomic m, MonadServer m)-              => m () -> Bool -> ActorId -> Char -> m Bool-effectDropEqp execSfx hit target symbol = do-  b <- getsState $ getActorBody target-  effectTransformEqp execSfx target symbol CEqp $-    dropEqpItem target b hit--effectTransformEqp :: forall m. (MonadAtomic m, MonadServer m)-                   => m () -> ActorId -> Char -> CStore-                   -> (ItemId -> Int -> m ())-                   -> m Bool-effectTransformEqp execSfx target symbol cstore m = do-  let hasSymbol (iid, _) = do-        item <- getsState $ getItemBody iid-        return $! jsymbol item == symbol-  assocsCStore <- getsState $ EM.assocs . getActorBag target cstore-  is <- if symbol == ' '-        then return assocsCStore-        else filterM hasSymbol assocsCStore-  if null is-    then return False-    else do-      mapM_ (uncurry m) is-      execSfx-      return True---- ** SendFlying---- | Shend the target actor flying like a projectile. The arguments correspond--- to @ToThrow@ and @Linger@ properties of items. If the actors are adjacent,--- the vector is directed outwards, if no, inwards, if it's the same actor,--- boldpos is used, if it can't, a random outward vector of length 10--- is picked.-effectSendFlying :: (MonadAtomic m, MonadServer m)-                 => m () -> Effect.ThrowMod-                 -> ActorId -> ActorId -> Maybe Bool-                 -> m Bool-effectSendFlying execSfx Effect.ThrowMod{..} source target modePush = do-  v <- sendFlyingVector source target modePush-  Kind.COps{cotile} <- getsState scops-  tb <- getsState $ getActorBody target-  lvl@Level{lxsize, lysize} <- getLevel (blid tb)-  let eps = 0-      fpos = bpos tb `shift` v-  case bla lxsize lysize eps (bpos tb) fpos of-    Nothing -> assert `failure` (fpos, tb)-    Just [] -> assert `failure` "projecting from the edge of level"-                      `twith` (fpos, tb)-    Just (pos : rest) -> do-      let t = lvl `at` pos-      if not $ Tile.isWalkable cotile t-        then return False  -- supported by a wall-        else do-          weightAssocs <- fullAssocsServer target [CInv, CEqp, COrgan]-          let weight = sum $ map (jweight . itemBase . snd) weightAssocs-              path = bpos tb : pos : rest-              (trajectory, (speed, _)) =-                computeTrajectory weight throwVelocity throwLinger path-              ts = Just (trajectory, speed)-          unless (btrajectory tb == ts) $-            execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts-          execSfx-          return True--sendFlyingVector :: (MonadAtomic m, MonadServer m)-                 => ActorId -> ActorId -> Maybe Bool -> m Vector-sendFlyingVector source target modePush = do-  sb <- getsState $ getActorBody source-  if source == target then do-    if boldpos sb == bpos sb then rndToAction $ do-      z <- randomR (-10, 10)-      oneOf [Vector 10 z, Vector (-10) z, Vector z 10, Vector z (-10)]-    else-      return $! vectorToFrom (bpos sb) (boldpos sb)-  else do-    tb <- getsState $ getActorBody target-    let (sp, tp) = if adjacent (bpos sb) (bpos tb)-                   then let pos = if chessDist (boldpos sb) (bpos tb)-                                     > chessDist (bpos sb) (bpos tb)-                                  then boldpos sb  -- avoid cardinal dir-                                  else bpos sb-                        in (pos, bpos tb)-                   else (bpos sb, bpos tb)-        pushV = vectorToFrom tp sp-        pullV = vectorToFrom sp tp-    return $! case modePush of-                Just True -> pushV-                Just False -> pullV-                Nothing | adjacent (bpos sb) (bpos tb) -> pushV-                Nothing -> pullV---- ** Teleport---- | Teleport the target actor.--- Note that projectiles can be teleported, too, for extra fun.-effectTeleport :: (MonadAtomic m, MonadServer m)-               => m () -> Int -> ActorId -> m Bool-effectTeleport execSfx range target = do-  Kind.COps{cotile} <- getsState scops-  b <- getsState $ getActorBody target-  Level{ltile} <- getLevel (blid b)-  as <- getsState $ actorList (const True) (blid b)-  let spos = bpos b-      dMinMax delta pos =-        let d = chessDist spos pos-        in d >= range - delta && d <= range + delta-      dist delta pos _ = dMinMax delta pos-  tpos <- rndToAction $ findPosTry 200 ltile-    (\p t -> Tile.isWalkable cotile t-             && (not (dMinMax 9 p)  -- don't loop, very rare-                 || not (Tile.hasFeature cotile F.NoActor t)-                    && unoccupied as p))-    [ dist $ 1-    , dist $ 1 + range `div` 9-    , dist $ 1 + range `div` 7-    , dist $ 1 + range `div` 5-    , dist $ 5-    , dist $ 7-    ]-  if not (dMinMax 9 tpos) then-    return False  -- very rare-  else do-    execUpdAtomic $ UpdMoveActor target spos tpos-    execSfx-    return True---- ** PolyItem--effectPolyItem :: (MonadAtomic m, MonadServer m)-               => m () -> CStore -> ActorId -> m Bool-effectPolyItem execSfx cstore target = do-  allAssocs <- fullAssocsServer target [cstore]-  case allAssocs of-    [] -> return False-    (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of-      Just ItemDisco{itemKind} -> do-        let maxCount = Dice.maxDice $ icount itemKind-        if itemK >= maxCount-        then do-          let c = CActor target cstore-          execUpdAtomic $ UpdDestroyItem iid itemBase maxCount c-          execSfx-          effectCreateItem 1 target-        else do-          tb <- getsState $ getActorBody target-          execSfxAtomic $ SfxMsgFid (bfid tb) $-            "The purpose is served by" <+> tshow maxCount-            <+> "pieces of this item, not by" <+> tshow itemK <> "."-          return False-      _ -> assert `failure` (cstore, target, iid, itemFull)---- ** Identify--effectIdentify :: (MonadAtomic m, MonadServer m)-               => m () -> CStore -> ActorId -> m Bool-effectIdentify execSfx cstore target = do-  allAssocs <- fullAssocsServer target [cstore]-  case allAssocs of-    [] -> return False-    (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of-      Just ItemDisco{..} -> do-        -- TODO: use this (but faster, via traversing effects with 999)-        -- also to prevent sending any other UpdDiscover.-        let ided = Effect.Identified `elem` ifeature itemKind-            itemSecret = itemNoAE itemFull-            statsObvious = textAllAE False cstore itemFull-                           == textAllAE False cstore itemSecret-        if ided && statsObvious-          then return False-          else do-            execSfx-            tb <- getsState $ getActorBody target-            seed <- getsServer $ (EM.! iid) . sitemSeedD-            execUpdAtomic $ UpdDiscover (blid tb) (bpos tb) iid itemKindId seed-            return True-      _ -> assert `failure` (cstore, target, iid, itemFull)---- ** ActivateInv---- | Activate all activable items with the given symbol--- in the target actor's equipment (there's no variant that activates--- a random one, to avoid the incentive for carrying garbage).--- Only one item of each stack is activated (and possibly consumed).-effectActivateInv :: (MonadAtomic m, MonadServer m)-                  => m () -> ActorId -> Char -> m Bool-effectActivateInv execSfx target symbol = do-  effectTransformEqp execSfx target symbol CInv $ \iid _ ->-    applyItem target iid CInv---- ** Explode--effectExplode :: (MonadAtomic m, MonadServer m)-              => m () -> Text -> ActorId -> m Bool-effectExplode execSfx cgroup target = do-  tb <- getsState $ getActorBody target-  let itemFreq = [(cgroup, 1)]-      container = CActor target CEqp-  m2 <- rollAndRegisterItem (blid tb) itemFreq container False-  let (iid, (ItemFull{..}, _)) = fromMaybe (assert `failure` cgroup) m2-      Point x y = bpos tb-      projectN k100 n = do-        -- We pick a point at the border, not inside, to have a uniform-        -- distribution for the points the line goes through at each distance-        -- from the source. Otherwise, e.g., the points on cardinal-        -- and diagonal lines from the source would be more common.-        let fuzz = 2 + (k100 `xor` (itemK * n)) `mod` 9-            k = if itemK >= 8 && n < 8 then 0-                else if n < 8 && n >= 4 then 4 else n-            ps = take k $-              [ Point (x - 12) $ y + fuzz-              , Point (x - 12) $ y - fuzz-              , Point (x + 12) $ y + fuzz-              , Point (x + 12) $ y - fuzz-              , flip Point (y - 12) $ x + fuzz-              , flip Point (y - 12) $ x - fuzz-              , flip Point (y + 12) $ x + fuzz-              , flip Point (y + 12) $ x - fuzz-              ]-        forM_ ps $ \tpxy -> do-          let req = ReqProject tpxy k100 iid CEqp-          mfail <- projectFail target tpxy k100 iid CEqp True-          case mfail of-            Nothing -> return ()-            Just ProjectBlockTerrain -> return ()-            Just ProjectBlockActor | not $ bproj tb -> return ()-            Just failMsg -> execFailure target req failMsg-  -- All shrapnels bounce off obstacles many times before they destruct.-  forM_ [101..201] $ \k100 -> do-    bag2 <- getsState $ beqp . getActorBody target-    let mn2 = EM.lookup iid bag2-    maybe skip (projectN k100) mn2-  bag3 <- getsState $ beqp . getActorBody target-  let mn3 = EM.lookup iid bag3-  maybe skip (\k -> execUpdAtomic-                    $ UpdLoseItem iid itemBase k container) mn3-  execSfx-  return True  -- we avoid verifying that at least one projectile got off---- ** OneOf--effectOneOf :: (MonadAtomic m, MonadServer m)-            => [Effect.Effect Int] -> ActorId -> ActorId -> m Bool-effectOneOf l source target = do-  ef <-  rndToAction $ oneOf l-  effectSem ef source target
− Game/LambdaHack/Server/HandleRequestServer.hs 
@@ -1,467 +0,0 @@-{-# LANGUAGE GADTs #-}--- | Semantics of request.--- A couple of them do not take time, the rest does.--- Note that since the results are atomic commands, which are executed--- only later (on the server and some of the clients), all condition--- are checkd by the semantic functions in the context of the state--- before the server command. Even if one or more atomic actions--- are already issued by the point an expression is evaluated, they do not--- influence the outcome of the evaluation.--- TODO: document-module Game.LambdaHack.Server.HandleRequestServer-  ( handleRequestAI, handleRequestUI, reqMove-  ) where--import Control.Applicative-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Text (Text)--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind as TileKind-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.HandleEffectServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State---- | The semantics of server commands. The resulting actor id--- is of the actor that carried out the request.-handleRequestAI :: (MonadAtomic m, MonadServer m)-                => FactionId -> ActorId -> RequestAI -> m ActorId-handleRequestAI fid aid cmd = case cmd of-  ReqAITimed cmdT -> handleRequestTimed aid cmdT >> return aid-  ReqAILeader aidNew cmd2 -> do-    switchLeader fid aidNew-    handleRequestAI fid aidNew cmd2-  ReqAIPong -> return aid---- | The semantics of server commands. The resulting actor id--- is of the actor that carried out the request. @Nothing@ means--- the command took no time.-handleRequestUI :: (MonadAtomic m, MonadServer m)-                => FactionId -> RequestUI -> m (Maybe ActorId)-handleRequestUI fid cmd = case cmd of-  ReqUITimed cmdT -> do-    fact <- getsState $ (EM.! fid) . sfactionD-    let aid = fromMaybe (assert `failure` fact) $ gleader fact-    handleRequestTimed aid cmdT >> return (Just aid)-  ReqUILeader aidNew cmd2 -> do-    switchLeader fid aidNew-    handleRequestUI fid cmd2-  ReqUIGameRestart aid t d names ->-    reqGameRestart aid t d names >> return Nothing-  ReqUIGameExit aid d -> reqGameExit aid d >> return Nothing-  ReqUIGameSave -> reqGameSave >> return Nothing-  ReqUIAutomate -> reqAutomate fid >> return Nothing-  ReqUIPong _ -> return Nothing--handleRequestTimed :: (MonadAtomic m, MonadServer m)-                   => ActorId -> RequestTimed a -> m ()-handleRequestTimed aid cmd = case cmd of-  ReqMove target -> reqMove aid target-  ReqMelee target iid cstore -> reqMelee aid target iid cstore-  ReqDisplace target -> reqDisplace aid target-  ReqAlter tpos mfeat -> reqAlter aid tpos mfeat-  ReqWait -> reqWait aid-  ReqMoveItem iid k fromCStore toCStore ->-    reqMoveItem aid iid k fromCStore toCStore-  ReqProject p eps iid cstore -> reqProject aid p eps iid cstore-  ReqApply iid cstore -> reqApply aid iid cstore-  ReqTrigger mfeat -> reqTrigger aid mfeat--switchLeader :: MonadAtomic m-             => FactionId -> ActorId -> m ()-switchLeader fid aidNew = do-  cops <- getsState scops-  fact <- getsState $ (EM.! fid) . sfactionD-  bPre <- getsState $ getActorBody aidNew-  let mleader = gleader fact-      leadAtoms = [UpdLeadFaction fid mleader (Just aidNew)]-  mapM_ execUpdAtomic leadAtoms-  assert (Just aidNew /= mleader-          && not (bproj bPre)-          && not (isAllMoveFact cops fact)-         `blame` (aidNew, bPre, fid, fact)) skip-  assert (bfid bPre == fid-          `blame` "client tries to move other faction actors"-          `twith` (aidNew, bPre, fid, fact)) skip---- * ReqMove---- TODO: let only some actors/items leave smell, e.g., a Smelly Hide Armour--- and then remove the efficiency hack below that only heroes leave smell--- | Add a smell trace for the actor to the level. For now, only heroes--- leave smell.-addSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-addSmell aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  smellRadius <- sumOrganEqpServer Effect.EqpSlotAddSmell aid-  unless (bproj b || not (isHeroFact fact) || smellRadius > 0) $ do-    time <- getsState $ getLocalTime $ blid b-    lvl <- getLevel $ blid b-    let oldS = EM.lookup (bpos b) . lsmell $ lvl-        newTime = timeShift time smellTimeout-    execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS (Just newTime)---- | Actor moves or attacks.--- Note that client may not be able to see an invisible monster--- so it's the server that determines if melee took place, etc.--- Also, only the server is authorized to check if a move is legal--- and it needs full context for that, e.g., the initial actor position--- to check if melee attack does not try to reach to a distant tile.-reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()-reqMove source dir = do-  cops <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-  lvl <- getLevel lid-  let spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-  -- We start by checking actors at the the target position.-  tgt <- getsState $ posToActor tpos lid-  case tgt of-    Just ((target, tb), _) | not (bproj sb && bproj tb) -> do  -- visible or not-      -- Projectiles are too small to hit each other.-      -- Attacking does not require full access, adjacency is enough.-      -- Here the only weapon of projectiles is picked, too.-      mweapon <- pickWeaponServer source-      case mweapon of-        Nothing -> reqWait source-        Just (wp, cstore) -> reqMelee source target wp cstore-    _-      | accessible cops lvl spos tpos -> do-          -- Movement requires full access.-          execUpdAtomic $ UpdMoveActor source spos tpos-          addSmell source-      | otherwise ->-          -- Client foolishly tries to move into blocked, boring tile.-          execFailure source (ReqMove dir) MoveNothing---- * ReqMelee---- | Resolves the result of an actor moving into another.--- Actors on blocked positions can be attacked without any restrictions.--- For instance, an actor embedded in a wall can be attacked from--- an adjacent position. This function is analogous to projectGroupItem,--- but for melee and not using up the weapon.--- No problem if there are many projectiles at the spot. We just--- attack the one specified.-reqMelee :: (MonadAtomic m, MonadServer m)-         => ActorId -> ActorId -> ItemId -> CStore -> m ()-reqMelee source target iid cstore = do-  itemToF <- itemToFullServer-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  let adj = checkAdjacent sb tb-      req = ReqMelee target iid cstore-  if source == target then execFailure source req MeleeSelf-  else if not adj then execFailure source req MeleeDistant-  else do-    let sfid = bfid sb-        tfid = bfid tb-    sfact <- getsState $ (EM.! sfid) . sfactionD-    hurtBonus <- armorHurtBonus source target-    let isFightImpaired = hurtBonus <= -10-        block = braced tb-        hitA = if block && isFightImpaired-               then HitBlock 2-               else if block || isFightImpaired-                    then HitBlock 1-                    else HitClear-    execSfxAtomic $ SfxStrike source target iid hitA-    -- Deduct a hitpoint for a pierce of a projectile-    -- or due to a hurled actor colliding with another or a wall.-    case btrajectory sb of-      Nothing -> return ()-      Just (tra, speed) -> do-        execUpdAtomic $ UpdRefillHP source minusM-        unless (bproj sb || null tra) $-          -- Non-projectiles can't pierce, so terminate their flight.-          execUpdAtomic-          $ UpdTrajectory source (btrajectory sb) (Just ([], speed))-    -- Msgs inside itemEffect describe the target part.-    itemEffectAndDestroy source target iid (itemToF iid 1) cstore-    -- The only way to start a war is to slap an enemy. Being hit by-    -- and hitting projectiles count as unintentional friendly fire.-    let friendlyFire = bproj sb || bproj tb-        fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)-    unless (friendlyFire-            || isAtWar sfact tfid  -- already at war-            || isAllied sfact tfid  -- allies never at war-            || sfid == tfid) $-      execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War---- * ReqDisplace---- | Actor tries to swap positions with another.-reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()-reqDisplace source target = do-  cops <- getsState scops-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  tfact <- getsState $ (EM.! bfid tb) . sfactionD-  let spos = bpos sb-      tpos = bpos tb-      adj = checkAdjacent sb tb-      atWar = isAtWar tfact (bfid sb)-      req = ReqDisplace target-  activeItems <- activeItemsServer target-  dEnemy <- getsState $ dispEnemy source target activeItems-  if not adj then execFailure source req DisplaceDistant-  else if atWar && not dEnemy-  then do-    mweapon <- pickWeaponServer source-    case mweapon of-      Nothing -> reqWait source-      Just (wp, cstore)  -> reqMelee source target wp cstore-        -- DisplaceDying, DisplaceSupported-  else do-    let lid = blid sb-    lvl <- getLevel lid-    -- Displacing requires full access.-    if accessible cops lvl spos tpos then do-      tgts <- getsState $ posToActors tpos lid-      case tgts of-        [] -> assert `failure` (source, sb, target, tb)-        [_] -> do-          execUpdAtomic $ UpdDisplaceActor source target-          addSmell source-          addSmell target-        _ -> execFailure source req DisplaceProjectiles-    else do-      -- Client foolishly tries to displace an actor without access.-      execFailure source req DisplaceAccess---- * ReqAlter---- | Search and/or alter the tile.------ Note that if @serverTile /= freshClientTile@, @freshClientTile@--- should not be alterable (but @serverTile@ may be).-reqAlter :: (MonadAtomic m, MonadServer m)-         => ActorId -> Point -> Maybe F.Feature -> m ()-reqAlter source tpos mfeat = do-  Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-      spos = bpos sb-      req = ReqAlter tpos mfeat-  if not $ adjacent spos tpos then execFailure source req AlterDistant-  else do-    lvl <- getLevel lid-    let serverTile = lvl `at` tpos-        freshClientTile = hideTile cotile lvl tpos-        changeTo tgroup = do-          -- No @SfxAlter@, because the effect is obvious (e.g., opened door).-          toTile <- rndToAction $ fmap (fromMaybe $ assert `failure` tgroup)-                                  $ opick tgroup (const True)-          unless (toTile == serverTile) $ do-            execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile-            case (Tile.isExplorable cotile serverTile,-                  Tile.isExplorable cotile toTile) of-              (False, True) -> execUpdAtomic $ UpdAlterClear lid 1-              (True, False) -> execUpdAtomic $ UpdAlterClear lid (-1)-              _ -> return ()-        feats = case mfeat of-          Nothing -> TileKind.tfeature $ okind serverTile-          Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]-          Just _ -> []-        toAlter feat =-          case feat of-            F.OpenTo tgroup -> Just tgroup-            F.CloseTo tgroup -> Just tgroup-            F.ChangeTo tgroup -> Just tgroup-            _ -> Nothing-        groupsToAlterTo = mapMaybe toAlter feats-    as <- getsState $ actorList (const True) lid-    if null groupsToAlterTo && serverTile == freshClientTile then-      -- Neither searching nor altering possible; silly client.-      execFailure source req AlterNothing-    else do-      if EM.null $ lvl `atI` tpos then-        if unoccupied as tpos then do-          when (serverTile /= freshClientTile) $ do-            -- Search, in case some actors (of other factions?)-            -- don't know this tile.-            execUpdAtomic $ UpdSearchTile source tpos freshClientTile serverTile-          maybe skip changeTo $ listToMaybe groupsToAlterTo-            -- TODO: pick another, if the first one void-          -- Perform an effect, if any permitted.-          void $ triggerEffect source feats-        else execFailure source req AlterBlockActor-      else execFailure source req AlterBlockItem---- * ReqWait---- | Do nothing.------ Something is sometimes done in 'LoopAction.setBWait'.-reqWait :: MonadAtomic m => ActorId -> m ()-reqWait _ = return ()---- * ReqMoveItem--reqMoveItem :: (MonadAtomic m, MonadServer m)-            => ActorId -> ItemId -> Int -> CStore -> CStore -> m ()-reqMoveItem aid iid k fromCStore toCStore = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsServer aid-  let moveItem = do-        when (fromCStore == CGround) $ do-          seed <- getsServer $ (EM.! iid) . sitemSeedD-          execUpdAtomic $ UpdDiscoverSeed (blid b) (bpos b) iid seed-        upds <- generalMoveItem iid k (CActor aid fromCStore)-                                      (CActor aid toCStore)-        mapM_ execUpdAtomic upds-      req = ReqMoveItem iid k fromCStore toCStore-  if k < 1 || fromCStore == toCStore then execFailure aid req ItemNothing-  else if toCStore == CEqp-          && eqpOverfull b k then execFailure aid req EqpOverfull-  else if fromCStore /= CSha && toCStore /= CSha then moveItem-  else do-    if calmEnough b activeItems then moveItem-    else execFailure aid req ItemNotCalm---- * ReqProject--reqProject :: (MonadAtomic m, MonadServer m)-           => ActorId    -- ^ actor projecting the item (is on current lvl)-           -> Point      -- ^ target position of the projectile-           -> Int        -- ^ digital line parameter-           -> ItemId     -- ^ the item to be projected-           -> CStore     -- ^ whether the items comes from floor or inventory-           -> m ()-reqProject source tpxy eps iid cstore = assert (cstore /= CSha) $ do-  mfail <- projectFail source tpxy eps iid cstore False-  let req = ReqProject tpxy eps iid cstore-  maybe skip (execFailure source req) mfail---- * ReqApply--reqApply :: (MonadAtomic m, MonadServer m)-         => ActorId  -- ^ actor applying the item (is on current level)-         -> ItemId   -- ^ the item to be applied-         -> CStore   -- ^ the location of the item-         -> m ()-reqApply aid iid cstore = assert (cstore /= CSha) $ do-  bag <- getsState $ getActorBag aid cstore-  let req = ReqApply iid cstore-  if EM.notMember iid bag-    then execFailure aid req ApplyOutOfReach-    else do-      actorBlind <- radiusBlind-                    <$> sumOrganEqpServer Effect.EqpSlotAddSight aid-      item <- getsState $ getItemBody iid-      let blindScroll = jsymbol item == '?' && actorBlind-      if blindScroll-        then execFailure aid req ApplyBlind-        else applyItem aid iid cstore---- * ReqTrigger---- | Perform the effect specified for the tile in case it's triggered.-reqTrigger :: (MonadAtomic m, MonadServer m)-           => ActorId -> Maybe F.Feature -> m ()-reqTrigger aid mfeat = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  sb <- getsState $ getActorBody aid-  let lid = blid sb-  lvl <- getLevel lid-  let tpos = bpos sb-      serverTile = lvl `at` tpos-      feats = case mfeat of-        Nothing -> TileKind.tfeature $ okind serverTile-        Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]-        Just _ -> []-      req = ReqTrigger mfeat-  go <- triggerEffect aid feats-  unless go $ execFailure aid req TriggerNothing--triggerEffect :: (MonadAtomic m, MonadServer m)-              => ActorId -> [F.Feature] -> m Bool-triggerEffect aid feats = do-  sb <- getsState $ getActorBody aid-  let tpos = bpos sb-      triggerFeat feat =-        case feat of-          F.Cause ef -> do-            -- No block against tile, hence unconditional.-            execSfxAtomic $ SfxTrigger aid tpos feat-            void $ effectsSem [ef] aid aid False-            return True-          _ -> return False-  goes <- mapM triggerFeat feats-  return $! or goes---- * ReqGameRestart---- TODO: implement a handshake and send hero names there,--- so that they are available in the first game too,--- not only in subsequent, restarted, games.-reqGameRestart :: (MonadAtomic m, MonadServer m)-               => ActorId -> Text -> Int -> [(Int, (Text, Text))] -> m ()-reqGameRestart aid stInfo d configHeroNames = do-  modifyServer $ \ser ->-    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d-                                     , sdebugCli = (sdebugCli (sdebugNxt ser))-                                                     {sdifficultyCli = d}-                                     }}-  b <- getsState $ getActorBody aid-  let fid = bfid b-  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD-  modifyServer $ \ser ->-    ser { squit = True  -- do this at once-        , sheroNames = EM.insert fid configHeroNames $ sheroNames ser }-  revealItems Nothing Nothing-  execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt-                $ Just $ Status Restart (fromEnum $ blid b) stInfo---- * ReqGameExit--reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()-reqGameExit aid d = do-  modifyServer $ \ser ->-    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d-                                     , sdebugCli = (sdebugCli (sdebugNxt ser))-                                                     {sdifficultyCli = d}-                                     }}-  b <- getsState $ getActorBody aid-  let fid = bfid b-  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD-  modifyServer $ \ser -> ser {sbkpSave = True}-  modifyServer $ \ser -> ser {squit = True}  -- do this at once-  execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt-                $ Just $ Status Camping (fromEnum $ blid b) ""---- * ReqGameSave--reqGameSave :: MonadServer m => m ()-reqGameSave = do-  modifyServer $ \ser -> ser {sbkpSave = True}-  modifyServer $ \ser -> ser {squit = True}  -- do this at once---- * ReqAutomate--reqAutomate :: (MonadAtomic m, MonadServer m) => FactionId -> m ()-reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True
− Game/LambdaHack/Server/ItemRev.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | Server types and operations for items that don't involve server state--- nor our custom monads.-module Game.LambdaHack.Server.ItemRev-  ( ItemRev, buildItem, newItem-    -- * Item discovery types-  , DiscoRev, serverDiscos, ItemSeedDict-    -- * The @FlavourMap@ type-  , FlavourMap, emptyFlavourMap, dungeonFlavourMap-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.HashMap.Strict as HM-import qualified Data.Ix as Ix-import Data.List-import qualified Data.Set as S-import Data.Text (Text)--import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Content.ItemKind---- | The reverse map to @Discovery@, needed for item creation.-type DiscoRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx---- | The map of item ids to item seeds.--- The full map is known by the server.-type ItemSeedDict = EM.EnumMap ItemId ItemSeed--serverDiscos :: Kind.Ops ItemKind -> Rnd (Discovery, DiscoRev)-serverDiscos Kind.Ops{obounds, ofoldrWithKey} = do-  let ixs = map toEnum $ take (Ix.rangeSize obounds) [0..]-      shuffle :: Eq a => [a] -> Rnd [a]-      shuffle [] = return []-      shuffle l = do-        x <- oneOf l-        fmap (x :) $ shuffle (delete x l)-  shuffled <- shuffle ixs-  let f ik _ (ikMap, ikRev, ix : rest) =-        (EM.insert ix ik ikMap, EM.insert ik ix ikRev, rest)-      f ik  _ (ikMap, _, []) =-        assert `failure` "too short ixs" `twith` (ik, ikMap)-      (discoS, discoRev, _) =-        ofoldrWithKey f (EM.empty, EM.empty, shuffled)-  return (discoS, discoRev)---- | Build an item with the given stats.-buildItem :: FlavourMap -> DiscoRev -> Kind.Id ItemKind -> ItemKind -> LevelId-          -> Item-buildItem (FlavourMap flavour) discoRev ikChosen kind jlid =-  let jkindIx  = discoRev EM.! ikChosen-      jsymbol  = isymbol kind-      jname    = iname kind-      jflavour =-        case iflavour kind of-          [fl] -> fl-          _ -> flavour EM.! ikChosen-      jfeature = ifeature kind-      jweight = iweight kind-  in Item{..}---- | Generate an item based on level.-newItem :: Kind.COps -> FlavourMap -> DiscoRev-        -> Freqs -> LevelId -> AbsDepth -> AbsDepth-        -> Rnd (Maybe (ItemKnown, ItemFull, ItemSeed, Int, Text))-newItem Kind.COps{coitem=Kind.Ops{ofoldrGroup}}-        flavour discoRev itemFreq jlid-        ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) = do-  let findInterval x1y1 [] = (x1y1, (11, 0))-      findInterval x1y1 ((x, y) : rest) =-        if ld * 10 <= x * depth-        then (x1y1, (x, y))-        else findInterval (x, y) rest-      linearInterpolation dataset =-        -- We assume @dataset@ is sorted and between 1 and 10 inclusive.-        let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset-        in y1 + (y2 - y1) * (ld * 10 - x1 * depth)-           `divUp` ((x2 - x1) * depth)-      f itemGroup q p ik kind acc =-        let rarity = linearInterpolation (irarity kind)-        in (q * p * rarity, ((ik, kind), itemGroup)) : acc-      g (itemGroup, q) = ofoldrGroup itemGroup (f itemGroup q) []-      freqDepth = concatMap g itemFreq-      freq = toFreq ("newItem ('" <> tshow ld <> ")") freqDepth-  if nullFreq freq then return Nothing-  else do-    ((itemKindId, itemKind), itemGroup) <- frequency freq-    itemN <- castDice ldepth totalDepth (icount itemKind)-    seed <- fmap toEnum random-    let itemBase = buildItem flavour discoRev itemKindId itemKind jlid-        itemK = max 1 itemN-        iae = seedToAspectsEffects seed itemKind ldepth totalDepth-        itemFull = ItemFull {itemBase, itemK, itemDisco = Just itemDisco}-        itemDisco = ItemDisco {itemKindId, itemKind, itemAE = Just iae}-    return $ Just ( (itemBase, iae)-                  , itemFull-                  , seed-                  , itemK-                  , itemGroup )---- | Flavours assigned by the server to item kinds, in this particular game.-newtype FlavourMap = FlavourMap (EM.EnumMap (Kind.Id ItemKind) Flavour)-  deriving (Show, Binary)--emptyFlavourMap :: FlavourMap-emptyFlavourMap = FlavourMap EM.empty---- | Assigns flavours to item kinds. Assures no flavor is repeated,--- except for items with only one permitted flavour.-rollFlavourMap :: S.Set Flavour -> Kind.Id ItemKind -> ItemKind-               -> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour-                      , EM.EnumMap Char (S.Set Flavour) )-               -> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour-                      , EM.EnumMap Char (S.Set Flavour) )-rollFlavourMap fullFlavSet key ik rnd =-  let flavours = iflavour ik-  in if length flavours == 1-     then rnd-     else do-       (assocs, availableMap) <- rnd-       let available = EM.findWithDefault fullFlavSet (isymbol ik) availableMap-           proper = S.fromList flavours `S.intersection` available-       assert (not (S.null proper)-               `blame` "not enough flavours for items"-               `twith` (flavours, available, ik, availableMap)) $ do-         flavour <- oneOf (S.toList proper)-         let availableReduced = S.delete flavour available-         return ( EM.insert key flavour assocs-                , EM.insert (isymbol ik) availableReduced availableMap)---- | Randomly chooses flavour for all item kinds for this game.-dungeonFlavourMap :: Kind.Ops ItemKind -> Rnd FlavourMap-dungeonFlavourMap Kind.Ops{ofoldrWithKey} =-  liftM (FlavourMap . fst) $-    ofoldrWithKey (rollFlavourMap (S.fromList stdFlav))-                  (return (EM.empty, EM.empty))---- | Reverse item map, for item creation, to keep items and item identifiers--- in bijection.-type ItemRev = HM.HashMap ItemKnown ItemId
− Game/LambdaHack/Server/ItemServer.hs 
@@ -1,134 +0,0 @@--- | Server operations for items.-module Game.LambdaHack.Server.ItemServer-  ( rollAndRegisterItem, registerItem, createItems, placeItemsInDungeon-  , fullAssocsServer, activeItemsServer, itemToFullServer, mapActorCStore_-  ) where--import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.HashMap.Strict as HM-import Data.Key (mapWithKeyM_)-import Data.Text (Text)--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Server.ItemRev-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State--registerItem :: (MonadAtomic m, MonadServer m)-             => ItemKnown -> ItemSeed -> Int -> Container -> Bool -> m ItemId-registerItem itemKnown@(item, iae) seed k container verbose = do-  itemRev <- getsServer sitemRev-  let cmd = if verbose then UpdCreateItem else UpdSpotItem-  case HM.lookup itemKnown itemRev of-    Just iid -> do-      -- TODO: try to avoid this case for createItems,-      -- to make items more interesting-      execUpdAtomic $ cmd iid item k container-      return iid-    Nothing -> do-      icounter <- getsServer sicounter-      modifyServer $ \ser ->-        ser { sicounter = succ icounter-            , sitemRev = HM.insert itemKnown icounter (sitemRev ser)-            , sitemSeedD = EM.insert icounter seed (sitemSeedD ser)-            , sdiscoAE = EM.insert icounter iae (sdiscoAE ser)}-      execUpdAtomic $ cmd icounter item k container-      return $! icounter--createItems :: (MonadAtomic m, MonadServer m)-            => Int -> Point -> LevelId -> m ()-createItems n pos lid = do-  Level{litemFreq} <- getLevel lid-  let container = CFloor lid pos-  replicateM_ n $ void $ rollAndRegisterItem lid litemFreq container True--rollAndRegisterItem :: (MonadAtomic m, MonadServer m)-                    => LevelId -> Freqs -> Container -> Bool-                    -> m (Maybe (ItemId, (ItemFull, Text)))-rollAndRegisterItem lid itemFreq container verbose = do-  cops <- getsState scops-  flavour <- getsServer sflavour-  discoRev <- getsServer sdiscoRev-  totalDepth <- getsState stotalDepth-  Level{ldepth} <- getLevel lid-  m4 <- rndToAction-        $ newItem cops flavour discoRev itemFreq lid ldepth totalDepth-  case m4 of-    Nothing -> return Nothing-    Just (itemKnown, itemFull, seed, k, itemGroup) -> do-      iid <- registerItem itemKnown seed k container verbose-      return $ Just (iid, (itemFull, itemGroup))--placeItemsInDungeon :: (MonadAtomic m, MonadServer m) => m ()-placeItemsInDungeon = do-  Kind.COps{cotile} <- getsState scops-  let initialItems lid (Level{ltile, litemNum, lxsize, lysize}) = do-        let factionDist = max lxsize lysize - 5-        replicateM (3 * litemNum `div` 2) $ do-          Level{lfloor} <- getLevel lid-          let dist p = minimum $ maxBound : map (chessDist p) (EM.keys lfloor)-          pos <- rndToAction $ findPosTry 100 ltile-                   (\_ t -> Tile.isWalkable cotile t-                            && (not $ Tile.hasFeature cotile F.NoItem t))-                   [ \p t -> Tile.hasFeature cotile F.OftenItem t-                             && dist p > factionDist `div` 5-                   , \p t -> Tile.hasFeature cotile F.OftenItem t-                             && dist p > factionDist `div` 7-                   , \p t -> Tile.hasFeature cotile F.OftenItem t-                             && dist p > factionDist `div` 9-                   , \p t -> Tile.hasFeature cotile F.OftenItem t-                             && dist p > factionDist `div` 12-                   , \p _ -> dist p > factionDist `div` 5-                   , \p t -> Tile.hasFeature cotile F.OftenItem t-                             || dist p > factionDist `div` 7-                   , \p t -> Tile.hasFeature cotile F.OftenItem t-                             || dist p > factionDist `div` 9-                   , \p t -> Tile.hasFeature cotile F.OftenItem t-                             || dist p > factionDist `div` 12-                   , \p _ -> dist p > 1-                   , \p _ -> EM.notMember p lfloor-                   ]-          createItems 1 pos lid-  dungeon <- getsState sdungeon-  mapWithKeyM_ initialItems dungeon--fullAssocsServer :: MonadServer m-                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]-fullAssocsServer aid cstores = do-  cops <- getsState scops-  disco <- getsServer sdisco-  discoAE <- getsServer sdiscoAE-  getsState $ fullAssocs cops disco discoAE aid cstores--activeItemsServer :: MonadServer m => ActorId -> m [ItemFull]-activeItemsServer aid = do-  activeAssocs <- fullAssocsServer aid [CEqp, COrgan]-  return $! map snd activeAssocs--itemToFullServer :: MonadServer m => m (ItemId -> Int -> ItemFull)-itemToFullServer = do-  cops <- getsState scops-  disco <- getsServer sdisco-  discoAE <- getsServer sdiscoAE-  s <- getState-  let itemToF iid = itemToFull cops disco discoAE iid (getItemBody iid s)-  return itemToF---- | Mapping over actor's items from a give store.-mapActorCStore_ :: MonadServer m-                => CStore -> (ItemId -> Int -> m a) -> Actor ->  m ()-mapActorCStore_ cstore f b = do-  bag <- getsState $ getBodyActorBag b cstore-  mapM_ (uncurry f) $ EM.assocs bag
− Game/LambdaHack/Server/LoopServer.hs 
@@ -1,388 +0,0 @@-{-# LANGUAGE GADTs #-}--- | The main loop of the server, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Server.LoopServer (loopSer) where--import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Key (mapWithKeyM_)-import Data.List-import Data.Maybe-import qualified Data.Ord as Ord--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.ItemStrongest-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.EndServer-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.HandleEffectServer-import Game.LambdaHack.Server.HandleRequestServer-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.PeriodicServer-import Game.LambdaHack.Server.ProtocolServer-import Game.LambdaHack.Server.StartServer-import Game.LambdaHack.Server.State---- | Start a game session. Loop, communicating with clients.-loopSer :: (MonadAtomic m, MonadServerReadRequest m)-        => DebugModeSer-        -> (FactionId -> ChanServer ResponseUI RequestUI -> IO ())-        -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ())-        -> Kind.COps-        -> m ()-loopSer sdebug executorUI executorAI !cops = do-  -- Recover states and launch clients.-  let updConn = updateConn executorUI executorAI-  restored <- tryRestore cops sdebug-  case restored of-    Just (sRaw, ser) | not $ snewGameSer sdebug -> do  -- run a restored game-      -- First, set the previous cops, to send consistent info to clients.-      let setPreviousCops = const cops-      execUpdAtomic $ UpdResumeServer $ updateCOps setPreviousCops sRaw-      putServer ser-      sdebugNxt <- initDebug cops sdebug-      modifyServer $ \ser2 -> ser2 {sdebugNxt}-      applyDebug-      updConn-      initPer-      pers <- getsServer sper-      broadcastUpdAtomic $ \fid -> UpdResume fid (pers EM.! fid)-      -- Second, set the current cops and reinit perception.-      let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)-      -- @sRaw@ is correct here, because none of the above changes State.-      execUpdAtomic $ UpdResumeServer $ updateCOps setCurrentCops sRaw-      -- We dump RNG seeds here, in case the game wasn't run-      -- with --dumpInitRngs previously and we need to seeds.-      when (sdumpInitRngs sdebug) $ dumpRngs-    _ -> do  -- Starting the first new game for this savefile.-      -- Set up commandline debug mode-      let mrandom = case restored of-            Just (_, ser) -> Just $ srandom ser-            Nothing -> Nothing-      s <- gameReset cops sdebug mrandom-      sdebugNxt <- initDebug cops sdebug-      let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}-      modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs-                                 , sdebugSer = debugBarRngs }-      let speedup = speedupCOps (sallClear sdebugNxt)-      execUpdAtomic $ UpdRestartServer $ updateCOps speedup s-      updConn-      initPer-      reinitGame-      saveBkpAll False-  resetSessionStart-  -- Start a clip (a part of a turn for which one or more frames-  -- will be generated). Do whatever has to be done-  -- every fixed number of time units, e.g., monster generation.-  -- Run the leader and other actors moves. Eventually advance the time-  -- and repeat.-  let loop = do-        let factionArena fact = do-              case gleader fact of-               -- Even spawners and horrors need an active arena-               -- for their leader, or they start clogging stairs.-               Just leader -> do-                  b <- getsState $ getActorBody leader-                  return $ Just $ blid b-               Nothing -> return Nothing-        factionD <- getsState sfactionD-        marenas <- mapM factionArena $ EM.elems factionD-        let arenas = ES.toList $ ES.fromList $ catMaybes marenas-        assert (not $ null arenas) skip  -- game over not caught earlier-        mapM_ handleActors arenas-        quit <- getsServer squit-        if quit then do-          -- In case of game save+exit or restart, don't age levels (endClip)-          -- since possibly not all actors have moved yet.-          modifyServer $ \ser -> ser {squit = False}-          endOrLoop loop (restartGame updConn loop) gameExit (saveBkpAll True)-        else do-          continue <- endClip arenas-          when continue loop-  loop--endClip :: (MonadAtomic m, MonadServer m, MonadServerReadRequest m)-        => [LevelId] -> m Bool-endClip arenas = do-  Kind.COps{corule} <- getsState scops-  let stdRuleset = Kind.stdRuleset corule-      saveBkpClips = rsaveBkpClips stdRuleset-      leadLevelClips = rleadLevelClips stdRuleset-      ageProcessed lid processed =-        EM.insertWith absoluteTimeAdd lid timeClip processed-      ageServer lid ser = ser {sprocessed = ageProcessed lid $ sprocessed ser}-  mapM_ (modifyServer . ageServer) arenas-  execUpdAtomic $ UpdAgeGame (Delta timeClip) arenas-  -- Perform periodic dungeon maintenance.-  time <- getsState stime-  let clipN = time `timeFit` timeClip-      clipInTurn = let r = timeTurn `timeFit` timeClip-                   in assert (r > 2) r-      clipMod = clipN `mod` clipInTurn-  when (clipN `mod` saveBkpClips == 0) $ do-    modifyServer $ \ser -> ser {sbkpSave = False}-    saveBkpAll False-  when (clipN `mod` leadLevelClips == 0) leadLevelFlip-  -- Add monsters each turn, not each clip.-  -- Do this on only one of the arenas to prevent micromanagement,-  -- e.g., spreading leaders across levels to bump monster generation.-  if clipMod == 1 then do-    arena <- rndToAction $ oneOf arenas-    activatePeriodicLevel arena-    spawnMonster arena-    stopAfter <- getsServer $ sstopAfter . sdebugSer-    case stopAfter of-      Nothing -> return True-      Just stopA -> do-        exit <- elapsedSessionTimeGT stopA-        if exit then do-          tellAllClipPS-          gameExit-          return False  -- don't re-enter the game loop-        else return True-  else return True---- | Trigger periodic items for all actors on the given level.--- This is done each game turn, not player turn, not to overpower--- fast actors (assuming the effects are positive).-activatePeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m ()-activatePeriodicLevel lid = do-  time <- getsState $ getLocalTime lid-  let turnN = time `timeFit` timeTurn-      activatePeriodicItem aid (iid, itemFull) = do-        case strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull of-          Nothing -> return ()-          Just n -> when (turnN `mod` (100 `div` n) == 0) $-                      void $ itemEffect aid aid iid itemFull False True-            -- periodic activation doesn't destroy items, even non-Durable-      activatePeriodicActor aid = do-        allItems <- fullAssocsServer aid [COrgan, CEqp]-        mapM_ (activatePeriodicItem aid) allItems-  allActors <- getsState $ actorRegularAssocs (const True) lid-  mapM_ (\(aid, _) -> activatePeriodicActor aid) allActors---- | Perform moves for individual actors, as long as there are actors--- with the next move time less or equal to the end of current cut-off.-handleActors :: (MonadAtomic m, MonadServerReadRequest m)-             => LevelId -> m ()-handleActors lid = do-  -- The end of this clip, inclusive. This is used exclusively-  -- to decide which actors to process this time. Transparent to clients.-  timeCutOff <- getsServer $ EM.findWithDefault timeClip lid . sprocessed-  Level{lprio} <- getLevel lid-  quit <- getsServer squit-  factionD <- getsState sfactionD-  s <- getState-  let -- Actors of the same faction move together.-      -- TODO: insert wrt the order, instead of sorting-      isLeader (aid, b) = Just aid /= gleader (factionD EM.! bfid b)-      order = Ord.comparing $-        ((>= 0) . bhp . snd) &&& bfid . snd &&& isLeader &&& bsymbol . snd-      (atime, as) = EM.findMin lprio-      ams = map (\a -> (a, getActorBody a s)) as-      mnext | EM.null lprio = Nothing  -- no actor alive, wait until it spawns-            | otherwise = if atime > timeCutOff-                          then Nothing  -- no actor is ready for another move-                          else Just $ minimumBy order ams-      startActor aid = execSfxAtomic $ SfxActorStart aid-  case mnext of-    _ | quit -> return ()-    Nothing -> return ()-    Just (aid, b) | maybe False (null .fst) (btrajectory b) && bproj b -> do-      -- A projectile drops to the ground due to obstacles or range.-      assert (bproj b) skip-      startActor aid-      dieSer aid b False-      handleActors lid-    Just (aid, b) | bhp b < 0 && bproj b -> do-      -- A projectile hits an actor. The carried item is destroyed.-      -- TODO: perhaps don't destroy if no effect (NoEffect),-      -- to help testing items. But OTOH, we want most items to have-      -- some effect, even silly, for flavour. Anyway, if the silly-      -- effect identifies an item, the hit is not wasted, so this makes sense.-      startActor aid-      dieSer aid b True-      handleActors lid-    Just (aid, b) | bhp b <= 0 && not (bproj b) -> do-      -- An actor dies. Items drop to the ground-      -- and possibly a new leader is elected.-      startActor aid-      dieSer aid b False-      handleActors lid-    Just (aid, body) -> do-      startActor aid-      let side = bfid body-          fact = factionD EM.! side-          mleader = gleader fact-          aidIsLeader = mleader == Just aid-      queryUI <--        if playerUI (gplayer fact)-           && (aidIsLeader || not (playerLeader (gplayer fact))) then do-          let underAI = playerAI $ gplayer fact-          if underAI then do-            -- If UI client for the faction completely under AI control,-            -- ping often to sync frames and to catch ESC,-            -- which switches off Ai control.-            sendPingUI side-            fact2 <- getsState $ (EM.! side) . sfactionD-            let underAI2 = playerAI $ gplayer fact2-            return $! not underAI2-          else return True-        else return False-      let setBWait hasWait aidNew = do-            bPre <- getsState $ getActorBody aidNew-            when (hasWait /= bwait bPre) $-              execUpdAtomic $ UpdWaitActor aidNew hasWait-      if isJust $ btrajectory body then do-        timed <- setTrajectory aid-        when timed $ advanceTime aid-      else if queryUI then do-        cmdS <- sendQueryUI side aid-        -- TODO: check that the command is legal first, report and reject,-        -- but do not crash (currently server asserts things and crashes)-        aidNew <- handleRequestUI side cmdS-        let hasWait (ReqUITimed ReqWait{}) = True-            hasWait (ReqUILeader _ cmd) = hasWait cmd-            hasWait _ = False-        maybe skip (setBWait (hasWait cmdS)) aidNew-        -- Advance time once, after the leader switched perhaps many times.-        -- TODO: this is correct only when all heroes have the same-        -- speed and can't switch leaders by, e.g., aiming a wand-        -- of domination. We need to generalize by displaying-        -- "(next move in .3s [RET]" when switching leaders.-        -- RET waits .3s and gives back control,-        -- Any other key does the .3s wait and the action from the key-        -- at once.-        maybe skip advanceTime aidNew-      else do-        -- Clear messages in the UI client (if any), if the actor-        -- is a leader (which happens when a UI client is fully-        -- computer-controlled) or if faction is leaderless.-        -- We could record history more often, to avoid long reports,-        -- but we'd have to add -more- prompts.-        let mainUIactor = playerUI (gplayer fact)-                          && (aidIsLeader || not (playerLeader (gplayer fact)))-        when mainUIactor $ execUpdAtomic $ UpdRecordHistory side-        cmdS <- sendQueryAI side aid-        aidNew <- handleRequestAI side aid cmdS-        let hasWait (ReqAITimed ReqWait{}) = True-            hasWait (ReqAILeader _ cmd) = hasWait cmd-            hasWait _ = False-        setBWait (hasWait cmdS) aidNew-        -- AI always takes time and so doesn't loop.-        advanceTime aidNew-      handleActors lid--gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m ()-gameExit = do-  -- Kill all clients, including those that did not take part-  -- in the current game.-  -- Clients exit not now, but after they print all ending screens.-  -- debugPrint "Server kills clients"-  killAllClients-  -- Verify that the saved perception is equal to future reconstructed.-  persAccumulated <- getsServer sper-  fovMode <- getsServer $ sfovMode . sdebugSer-  ser <- getServer-  pers <- getsState $ \s -> dungeonPerception (fromMaybe Digital fovMode) s ser-  assert (persAccumulated == pers `blame` "wrong accumulated perception"-                                  `twith` (persAccumulated, pers)) skip--restartGame :: (MonadAtomic m, MonadServerReadRequest m)-            => m () -> m () -> m ()-restartGame updConn loop = do-  tellGameClipPS-  cops <- getsState scops-  sdebugNxt <- getsServer sdebugNxt-  srandom <- getsServer srandom-  s <- gameReset cops sdebugNxt $ Just srandom-  let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}-  modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs-                             , sdebugSer = debugBarRngs }-  execUpdAtomic $ UpdRestartServer s-  updConn-  initPer-  reinitGame-  saveBkpAll False-  loop---- TODO: This can be improved by adding a timeout--- and by asking clients to prepare--- a save (in this way checking they have permissions, enough space, etc.)--- and when all report back, asking them to commit the save.--- | Save game on server and all clients. Clients are pinged first,--- which greatly reduced the chance of saves being out of sync.-saveBkpAll :: (MonadAtomic m, MonadServerReadRequest m) => Bool -> m ()-saveBkpAll unconditional = do-  bench <- getsServer $ sbenchmark . sdebugSer-  when (unconditional || not bench) $ do-    factionD <- getsState sfactionD-    let ping fid _ = do-          sendPingAI fid-          when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid-    mapWithKeyM_ ping factionD-    execUpdAtomic UpdSaveBkp-    saveServer---- TODO: move somewhere?--- | Manage trajectory of a projectile.------ Colliding with a wall or actor doesn't take time, because--- the projectile does not move (the move is blocked).--- Not advancing time forces dead projectiles to be destroyed ASAP.--- Otherwise, with some timings, it can stay on the game map dead,--- blocking path of human-controlled actors and alarming the hapless human.-setTrajectory :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool-setTrajectory aid = do-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  lvl <- getLevel $ blid b-  let clearTrajectory speed = do-        -- Lose HP due to bumping into an obstacle.-        execUpdAtomic $ UpdRefillHP aid minusM-        execUpdAtomic $ UpdTrajectory aid-                                      (btrajectory b)-                                      (Just ([], speed))-        return $ not $ bproj b  -- projectiles must vanish soon-  case btrajectory b of-    Just ((d : lv), speed) ->-      if not $ accessibleDir cops lvl (bpos b) d-      then clearTrajectory speed-      else do-        when (bproj b && null lv) $ do-          let toColor = Color.BrBlack-          when (bcolor b /= toColor) $-            execUpdAtomic $ UpdColorActor aid (bcolor b) toColor-        reqMove aid d  -- hit clears trajectory of non-projectiles-        b2 <- getsState $ getActorBody aid-        if actorDying b2 then return $ not $ bproj b  -- don't clear trajectory-        else do-          unless (maybe False (null . fst) (btrajectory b2)) $-            execUpdAtomic $ UpdTrajectory aid-                                          (btrajectory b2)-                                          (Just (lv, speed))-          return True-    Just ([], _) -> do  -- non-projectile actor stops flying-      assert (not $ bproj b) skip-      execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing-      return False-    _ -> assert `failure` "Nothing trajectory" `twith` (aid, b)
− Game/LambdaHack/Server/MonadServer.hs 
@@ -1,244 +0,0 @@--- | 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.Server.MonadServer-  ( -- * The server monad-    MonadServer( getServer, getsServer, modifyServer, putServer-               , saveChanServer  -- exposed only to be implemented, not used-               , liftIO  -- exposed only to be implemented, not used-               )-    -- * Assorted primitives-  , debugPrint, saveServer, saveName, dumpRngs-  , restoreScore, registerScore-  , resetSessionStart, resetGameStart, elapsedSessionTimeGT-  , tellAllClipPS, tellGameClipPS-  , tryRestore, speedupCOps, rndToAction, getSetGen-  ) where--import qualified Control.Exception as Ex hiding (handle)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Control.Monad.State as St-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import System.Directory-import System.FilePath-import System.IO-import qualified System.Random as R-import System.Time--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.File-import qualified Game.LambdaHack.Common.HighScore as HighScore-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Save-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.State--class MonadStateRead m => MonadServer m where-  getServer      :: m StateServer-  getsServer     :: (StateServer -> a) -> m a-  modifyServer   :: (StateServer -> StateServer) -> m ()-  putServer      :: StateServer -> 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-  saveChanServer :: m (Save.ChanSave (State, StateServer))--debugPrint :: MonadServer m => Text -> m ()-debugPrint t = do-  debug <- getsServer $ sdbgMsgSer . sdebugSer-  when debug $ liftIO $ do-    T.hPutStrLn stderr t-    hFlush stderr--saveServer :: MonadServer m => m ()-saveServer = do-  s <- getState-  ser <- getServer-  toSave <- saveChanServer-  liftIO $ Save.saveToChan toSave (s, ser)--saveName :: String-saveName = serverSaveName---- | Dumps RNG states from the start of the game to stderr.-dumpRngs :: MonadServer m => m ()-dumpRngs = do-  rngs <- getsServer srngs-  liftIO $ do-    T.hPutStrLn stderr $ tshow rngs-    hFlush stderr---- TODO: refactor wrt Game.LambdaHack.Common.Save--- | Read the high scores table. Return the empty table if no file.-restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreTable-restoreScore Kind.COps{corule} = do-  let stdRuleset = Kind.stdRuleset corule-      scoresFile = rscoresFile stdRuleset-  dataDir <- liftIO appDataDir-  let path = dataDir </> scoresFile-  configExists <- liftIO $ doesFileExist path-  mscore <- liftIO $ do-    res <- Ex.try $-      if configExists then do-        s <- strictDecodeEOF path-        return $ Just s-      else return Nothing-    let handler :: Ex.SomeException -> IO (Maybe a)-        handler e = do-          let msg = "High score restore failed. The error message is:"-                    <+> (T.unwords . T.lines) (tshow e)-          delayPrint $ msg-          return Nothing-    either handler return res-  maybe (return HighScore.empty) return mscore---- | Generate a new score, register it and save.-registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m ()-registerScore status mbody fid = do-  cops@Kind.COps{corule} <- getsState scops-  assert (maybe True ((fid ==) . bfid) mbody) skip-  fact <- getsState $ (EM.! fid) . sfactionD-  total <- case mbody of-    Just body -> getsState $ snd . calculateTotal body-    Nothing -> case gleader fact of-      Nothing -> return 0-      Just aid -> do-        b <- getsState $ getActorBody aid-        getsState $ snd . calculateTotal b-  let stdRuleset = Kind.stdRuleset corule-      scoresFile = rscoresFile stdRuleset-  dataDir <- liftIO appDataDir-  -- Re-read the table in case it's changed by a concurrent game.-  table <- restoreScore cops-  time <- getsState stime-  date <- liftIO getClockTime-  DebugModeSer{sdifficultySer} <- getsServer sdebugSer-  factionD <- getsState sfactionD-  fightsSpawners <- fightsAgainstSpawners fid-  let path = dataDir </> scoresFile-      outputScore (worthMentioning, (ntable, pos)) =-        -- If not human, probably debugging, so dump instead of registering.-        if not $ playerAI $ gplayer fact then-          if worthMentioning then-            liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable)-          else return ()-        else-          debugPrint $ T.intercalate "\n"-          $ HighScore.showScore (pos, HighScore.getRecord pos ntable)-      diff | not $ playerUI $ gplayer fact = difficultyDefault-           | otherwise = sdifficultySer-      theirVic (fi, fa) | isAtWar fact fi-                          && not (isHorrorFact cops fa) = Just $ gvictims fa-                        | otherwise = Nothing-      theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD-      ourVic (fi, fa) | isAllied fact fi || fi == fid = Just $ gvictims fa-                      | otherwise = Nothing-      ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD-      registeredScore =-        HighScore.register table total time status date diff-                           (playerName $ gplayer fact)-                           ourVictims theirVictims fightsSpawners-  outputScore registeredScore--resetSessionStart :: MonadServer m => m ()-resetSessionStart = do-  sstart <- liftIO getClockTime-  modifyServer $ \ser -> ser {sstart}---- TODO: all this breaks when games are loaded; we'd need to save--- elapsed game clock time to fix this.-resetGameStart :: MonadServer m => m ()-resetGameStart = do-  sgstart <- liftIO getClockTime-  time <- getsState stime-  modifyServer $ \ser ->-    ser {sgstart, sallTime = absoluteTimeAdd (sallTime ser) time}--elapsedSessionTimeGT :: MonadServer m => Int -> m Bool-elapsedSessionTimeGT stopAfter = do-  current <- liftIO getClockTime-  TOD s p <- getsServer sstart-  return $! TOD (s + fromIntegral stopAfter) p <= current--tellAllClipPS :: MonadServer m => m ()-tellAllClipPS = do-  bench <- getsServer $ sbenchmark . sdebugSer-  when bench $ do-    TOD s p <- getsServer sstart-    TOD sCur pCur <- liftIO getClockTime-    allTime <- getsServer sallTime-    gtime <- getsState stime-    let time = absoluteTimeAdd allTime gtime-    let diff = fromIntegral sCur + fromIntegral pCur / 10e12-               - fromIntegral s - fromIntegral p / 10e12-        cps = fromIntegral (timeFit time timeClip) / diff :: Double-    debugPrint $ "Session time:" <+> tshow diff <> "s."-                 <+> "Average clips per second:" <+> tshow cps <> "."--tellGameClipPS :: MonadServer m => m ()-tellGameClipPS = do-  bench <- getsServer $ sbenchmark . sdebugSer-  when bench $ do-    TOD s p <- getsServer sgstart-    unless (s == 0) $ do  -- loaded game, don't report anything-      TOD sCur pCur <- liftIO getClockTime-      time <- getsState stime-      let diff = fromIntegral sCur + fromIntegral pCur / 10e12-                 - fromIntegral s - fromIntegral p / 10e12-          cps = fromIntegral (timeFit time timeClip) / diff :: Double-      debugPrint $ "Game time:" <+> tshow diff <> "s."-                   <+> "Average clips per second:" <+> tshow cps <> "."--tryRestore :: MonadServer m-           => Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer))-tryRestore Kind.COps{corule} sdebugSer = do-  let stdRuleset = Kind.stdRuleset corule-      scoresFile = rscoresFile stdRuleset-      pathsDataFile = rpathsDataFile stdRuleset-      prefix = ssavePrefixSer sdebugSer-  let copies = [( "GameDefinition" </> scoresFile-                , scoresFile )]-      name = fromMaybe "save" prefix <.> saveName-  liftIO $ Save.restoreGame name copies pathsDataFile---- | Compute and insert auxiliary optimized components into game content,--- to be used in time-critical sections of the code.-speedupCOps :: Bool -> Kind.COps -> Kind.COps-speedupCOps allClear copsSlow@Kind.COps{cotile=tile} =-  let ospeedup = Tile.speedup allClear tile-      cotile = tile {Kind.ospeedup = Just ospeedup}-  in copsSlow {Kind.cotile = cotile}---- | Invoke pseudo-random computation with the generator kept in the state.-rndToAction :: MonadServer m => Rnd a -> m a-rndToAction r = do-  g <- getsServer srandom-  let (a, ng) = St.runState r g-  modifyServer $ \ser -> ser {srandom = ng}-  return $! a---- | Gets a random generator from the arguments or, if not present,--- generates one.-getSetGen :: MonadServer m-          => Maybe R.StdGen-          -> m R.StdGen-getSetGen mrng = case mrng of-  Just rnd -> return rnd-  Nothing -> liftIO $ R.newStdGen
− Game/LambdaHack/Server/PeriodicServer.hs 
@@ -1,260 +0,0 @@--- | Server operations performed periodically in the game loop--- and related operations.-module Game.LambdaHack.Server.PeriodicServer-  ( spawnMonster, addAnyActor, dominateFidSfx, advanceTime, leadLevelFlip-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe--import Game.LambdaHack.Atomic-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Server.CommonServer-import Game.LambdaHack.Server.ItemRev-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State---- TODO: civilians would have 'it' pronoun--- | Sapwn, possibly, a monster according to the level's actor groups.--- We assume heroes are never spawned.-spawnMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()-spawnMonster lid = do-  -- We check the number of current dungeon dwellers (whether spawned or not)-  -- to decide if more should be spawned.-  f <- getsState $ \s fid -> isSpawnFact $ sfactionD s EM.! fid-  spawns <- getsState $ actorRegularList f lid-  totalDepth <- getsState stotalDepth-  -- We do not check @playerSpawn@ of any faction, but just take @lactorFreq@.-  Level{ldepth, lactorFreq} <- getLevel lid-  rc <- rndToAction $ monsterGenChance ldepth totalDepth (length spawns)-  when rc $ do-    time <- getsState $ getLocalTime lid-    maid <- addAnyActor lactorFreq lid time Nothing-    case maid of-      Nothing -> return ()-      Just aid -> do-        b <- getsState $ getActorBody aid-        mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD-        when (isNothing mleader) $-          execUpdAtomic $ UpdLeadFaction (bfid b) Nothing (Just aid)--addAnyActor :: (MonadAtomic m, MonadServer m)-            => Freqs -> LevelId -> Time -> Maybe Point-            -> m (Maybe ActorId)-addAnyActor actorFreq lid time mpos = do-  -- We bootstrap the actor by first creating the trunk of the actor's body-  -- contains the constant properties.-  cops <- getsState scops-  flavour <- getsServer sflavour-  discoRev <- getsServer sdiscoRev-  totalDepth <- getsState stotalDepth-  lvl@Level{ldepth} <- getLevel lid-  factionD <- getsState sfactionD-  m4 <- rndToAction-        $ newItem cops flavour discoRev actorFreq lid ldepth totalDepth-  case m4 of-    Nothing -> return Nothing-    Just (itemKnown, trunkFull, seed, k, _) -> do-      let ik = maybe (assert `failure` trunkFull) itemKind $ itemDisco trunkFull-          freqNames = map fst $ ifreq ik-          f fact = playerFaction (gplayer fact)-          factNames = map f $ EM.elems factionD-          fidName = case freqNames `intersect` factNames of-            [] -> head factNames  -- fall back to an arbitrary faction-            fName : _ -> fName-          g (_, fact) = playerFaction (gplayer fact) == fidName-          mfid = find g $ EM.assocs factionD-          fid = fst $ fromMaybe (assert `failure` (factionD, fidName)) mfid-      pers <- getsServer sper-      let allPers = ES.unions $ map (totalVisible . (EM.! lid))-                    $ EM.elems $ EM.delete fid pers  -- expensive :(-      pos <- case mpos of-        Just pos -> return pos-        Nothing -> do-          rollPos <- getsState $ rollSpawnPos cops allPers lid lvl fid-          rndToAction rollPos-      let container = (CTrunk fid lid pos)-      trunkId <- registerItem itemKnown seed k container False-      addActorIid trunkId trunkFull fid pos lid id "it" time--rollSpawnPos :: Kind.COps -> ES.EnumSet Point-             -> LevelId -> Level -> FactionId -> State-             -> Rnd Point-rollSpawnPos Kind.COps{cotile} visible-             lid Level{ltile, lxsize, lysize} fid s = do-  let factionDist = max lxsize lysize - 5-      inhabitants = actorList (/= fid) lid s  -- projectiles can have cameras-      as = actorList (const True) lid s-      isLit = Tile.isLit cotile-      distantAtLeast d p _ =-        all (\b -> chessDist (bpos b) p > d) inhabitants-  -- Not considering F.OftenActor, because monsters emerge from hidden ducts,-  -- which are easier to hide in crampy corridors that lit halls.-  findPosTry 100 ltile-    ( \p t -> Tile.isWalkable cotile t-              && not (Tile.hasFeature cotile F.NoActor t)-              && unoccupied as p)-    [ \_ t -> not (isLit t)  -- no such tiles on some maps-    , distantAtLeast factionDist-    , distantAtLeast $ factionDist `div` 2-    , distantAtLeast $ factionDist `div` 4-    , distantAtLeast $ factionDist `div` 6-    , \p _ -> not $ p `ES.member` visible-    , distantAtLeast 3  -- otherwise a fast actor can walk and hit in one turn-    ]-dominateFidSfx :: (MonadAtomic m, MonadServer m)-               => FactionId -> ActorId -> m Bool-dominateFidSfx fid target = do-  actorSk <- actorSkillsServer target (Just target)-  let canMove = EM.findWithDefault 0 Ability.AbMove actorSk > 0-  if canMove-    then do-      tb <- getsState $ getActorBody target-      let execSfx = execSfxAtomic-                    $ SfxEffect (boldfid tb) target Effect.Dominate-      execSfx-      dominateFid fid target-      execSfx-      return True-    else-      return False--dominateFid :: (MonadAtomic m, MonadServer m)-            => FactionId -> ActorId -> m ()-dominateFid fid target = do-  Kind.COps{cotile} <- getsState scops-  tb0 <- getsState $ getActorBody target-  -- Only record the initial domination as a kill.-  disco <- getsServer sdisco-  trunk <- getsState $ getItemBody $ btrunk tb0-  let ikind = disco EM.! jkindIx trunk-  when (boldfid tb0 == bfid tb0) $ execUpdAtomic $ UpdRecordKill target ikind 1-  electLeader (bfid tb0) (blid tb0) target-  fact <- getsState $ (EM.! bfid tb0) . sfactionD-  -- Prevent the faction's stash from being lost in case they are not spawners.-  when (isNothing $ gleader fact) $ moveStores target CSha CInv-  tb <- getsState $ getActorBody target-  deduceKilled tb-  ais <- getsState $ getCarriedAssocs tb-  calmMax <- sumOrganEqpServer Effect.EqpSlotAddMaxCalm target-  execUpdAtomic $ UpdLoseActor target tb ais-  let bNew = tb { bfid = fid-                , boldfid = bfid tb-                , bcalm = max 0 $ xM calmMax `div` 2 }-  execUpdAtomic $ UpdSpotActor target bNew ais-  mleaderOld <- getsState $ gleader . (EM.! fid) . sfactionD-  -- Keep the leader if he is on stairs. We don't want to clog stairs.-  keepLeader <- case mleaderOld of-    Nothing -> return False-    Just leaderOld -> do-      body <- getsState $ getActorBody leaderOld-      lvl <- getLevel $ blid body-      return $! Tile.isStair cotile $ lvl `at` bpos body-  unless keepLeader $-    -- Focus on the dominated actor, by making him a leader.-    execUpdAtomic $ UpdLeadFaction fid mleaderOld (Just target)---- | Advance the move time for the given actor, check if he's dominated--- and update his calm. We don't update calm once per game turn--- (even though it would make fast actors less overpowered),--- beucase the effects of close enemies would sometimes manifest only after--- a couple of player turns (or perhaps never at all, if the player and enemy--- move away before that moment). A side effect is that under peaceful--- circumstances, non-max calm cases a consistent regeneration UI indicator--- to be displayed each turn (not every few turns).-advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-advanceTime aid = do-  b <- getsState $ getActorBody aid-  activeItems <- activeItemsServer aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let t = ticksPerMeter $ bspeed b activeItems-  execUpdAtomic $ UpdAgeActor aid t-  unless (bproj b) $ do-    dominated <--      if bcalm b == 0-         && boldfid b /= bfid b-         && playerLeader (gplayer fact)  -- animals never Calm-dominated-      then dominateFidSfx (boldfid b) aid-      else return False-    unless dominated $ do-      newCalmDelta <- getsState $ regenCalmDelta b activeItems-      let clearMark = 0-      unless (newCalmDelta <= 0) $-        -- Update delta for the current player turn.-        execUpdAtomic $ UpdRefillCalm aid newCalmDelta-      unless (bcalmDelta b == ResDelta 0 0) $-        -- Clear delta for the next player turn.-        execUpdAtomic $ UpdRefillCalm aid clearMark-      unless (bhpDelta b == ResDelta 0 0) $-        -- Clear delta for the next player turn.-        execUpdAtomic $ UpdRefillHP aid clearMark--leadLevelFlip :: (MonadAtomic m, MonadServer m) => m ()-leadLevelFlip = do-  cops@Kind.COps{cotile} <- getsState scops-  let canFlip fact =-        -- We don't have to check @playerLeader@: @gleader@ would be @Nothing@.-        playerAI (gplayer fact) || isAllMoveFact cops fact-      flipFaction fact | not $ canFlip fact = return ()-      flipFaction fact = do-        case gleader fact of-          Nothing -> return ()-          Just leader -> do-            body <- getsState $ getActorBody leader-            lvl2 <- getLevel $ blid body-            let leaderStuck = waitedLastTurn body-                t = lvl2 `at` bpos body-            -- Keep the leader: he is on stairs and not stuck-            -- and we don't want to clog stairs or get pushed to another level.-            unless (not leaderStuck && Tile.isStair cotile t) $ do-              actorD <- getsState sactorD-              let ourLvl (lid, lvl) =-                    ( lid-                    , EM.size (lfloor lvl)-                    , -- Drama levels skipped, hence @Regular@.-                      actorRegularAssocsLvl (== bfid body) lvl actorD )-              ours <- getsState $ map ourLvl . EM.assocs . sdungeon-              -- Non-humans, being born in the dungeon, have a rough idea of-              -- the number of items left on the level and will focus-              -- on levels they started exploring and that have few items-              -- left. This is to to explore them completely, leave them-              -- once and for all and concentrate forces on another level.-              -- In addition, sole stranded actors tend to become leaders-              -- so that they can join the main force ASAP.-              let freqList = [ (k, (lid, a))-                             | (lid, itemN, (a, _) : rest) <- ours-                             , not leaderStuck || lid /= blid body-                             , let len = 1 + (min 10 $ length rest)-                                   k = 1000000 `div` (3 * itemN + len) ]-              unless (null freqList) $ do-                (lid, a) <- rndToAction $ frequency-                                        $ toFreq "leadLevel" freqList-                unless (lid == blid body) $  -- flip levels rather than actors-                  execUpdAtomic-                  $ UpdLeadFaction (bfid body) (Just leader) (Just a)-  factionD <- getsState sfactionD-  mapM_ flipFaction $ EM.elems factionD
− Game/LambdaHack/Server/ProtocolServer.hs 
@@ -1,219 +0,0 @@--- | The server definitions for the server-client communication protocol.-module Game.LambdaHack.Server.ProtocolServer-  ( -- * The communication channels-    ChanServer(..)-  , ConnServerDict  -- exposed only to be implemented, not used-    -- * The server-client communication monad-  , MonadServerReadRequest-      ( getDict  -- exposed only to be implemented, not used-      , getsDict  -- exposed only to be implemented, not used-      , modifyDict  -- exposed only to be implemented, not used-      , putDict  -- exposed only to be implemented, not used-      , liftIO  -- exposed only to be implemented, not used-      )-    -- * Protocol-  , sendUpdateAI, sendQueryAI, sendPingAI-  , sendUpdateUI, sendQueryUI, sendPingUI-    -- * Assorted-  , killAllClients, childrenServer, updateConn-  ) where--import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM (TQueue, atomically)-import qualified Control.Concurrent.STM as STM-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Key (mapWithKeyM, mapWithKeyM_)-import Game.LambdaHack.Common.Thread-import System.IO.Unsafe (unsafePerformIO)--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Server.DebugServer-import Game.LambdaHack.Server.MonadServer hiding (liftIO)-import Game.LambdaHack.Server.State---- | Connection channel between the server and a single client.-data ChanServer resp req = ChanServer-  { responseS :: !(TQueue resp)-  , requestS  :: !(TQueue req)-  }---- | Connections to the human-controlled client of a faction and--- to the AI client for the same faction.-type ConnServerFaction = ( Maybe (ChanServer ResponseUI RequestUI)-                         , ChanServer ResponseAI RequestAI )---- | Connection information for all factions, indexed by faction identifier.-type ConnServerDict = EM.EnumMap FactionId ConnServerFaction---- TODO: refactor so that the monad is split in 2 and looks analogously--- to the Client monads. Restrict the Dict to implementation modules.--- Then on top of that implement sendQueryAI, etc.--- For now we call it MonadServerReadRequest--- though it also has the functionality of MonadServerWriteResponse.---- | The server monad with the ability to communicate with clients.-class MonadServer m => MonadServerReadRequest m where-  getDict      :: m ConnServerDict-  getsDict     :: (ConnServerDict -> a) -> m a-  modifyDict   :: (ConnServerDict -> ConnServerDict) -> m ()-  putDict      :: ConnServerDict -> m ()-  liftIO       :: IO a -> m a--writeTQueueAI :: MonadServerReadRequest m-              => ResponseAI -> TQueue ResponseAI -> m ()-writeTQueueAI cmd responseS = do-  debug <- getsServer $ sniffOut . sdebugSer-  when debug $ debugResponseAI cmd-  liftIO $ atomically $ STM.writeTQueue responseS cmd--writeTQueueUI :: MonadServerReadRequest m-              => ResponseUI -> TQueue ResponseUI -> m ()-writeTQueueUI cmd responseS = do-  debug <- getsServer $ sniffOut . sdebugSer-  when debug $ debugResponseUI cmd-  liftIO $ atomically $ STM.writeTQueue responseS cmd--readTQueueAI :: MonadServerReadRequest m-             => TQueue RequestAI -> m RequestAI-readTQueueAI requestS = liftIO $ atomically $ STM.readTQueue requestS--readTQueueUI :: MonadServerReadRequest m-             => TQueue RequestUI -> m RequestUI-readTQueueUI requestS = liftIO $ atomically $ STM.readTQueue requestS--sendUpdateAI :: MonadServerReadRequest m-             => FactionId -> ResponseAI -> m ()-sendUpdateAI fid cmd = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI cmd $ responseS conn--sendQueryAI :: MonadServerReadRequest m-            => FactionId -> ActorId -> m RequestAI-sendQueryAI fid aid = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI (RespQueryAI aid) $ responseS conn-  req <- readTQueueAI $ requestS conn-  debug <- getsServer $ sniffIn . sdebugSer-  when debug $ debugRequestAI aid req-  return $! req--sendPingAI :: (MonadAtomic m, MonadServerReadRequest m)-           => FactionId -> m ()-sendPingAI fid = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI RespPingAI $ responseS conn-  -- debugPrint $ "AI client" <+> tshow fid <+> "pinged..."-  cmdPong <- readTQueueAI $ requestS conn-  -- debugPrint $ "AI client" <+> tshow fid <+> "responded."-  case cmdPong of-    ReqAIPong -> return ()-    _ -> assert `failure` (fid, cmdPong)--sendUpdateUI :: MonadServerReadRequest m-             => FactionId -> ResponseUI -> m ()-sendUpdateUI fid cmd = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just conn ->-      writeTQueueUI cmd $ responseS conn--sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m)-            => FactionId -> ActorId -> m RequestUI-sendQueryUI fid aid = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just conn -> do-      writeTQueueUI RespQueryUI $ responseS conn-      req <- readTQueueUI $ requestS conn-      debug <- getsServer $ sniffIn . sdebugSer-      when debug $ debugRequestUI aid req-      return $! req--sendPingUI :: (MonadAtomic m, MonadServerReadRequest m)-           => FactionId -> m ()-sendPingUI fid = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just conn -> do-      writeTQueueUI RespPingUI $ responseS conn-      -- debugPrint $ "UI client" <+> tshow fid <+> "pinged..."-      cmdPong <- readTQueueUI $ requestS conn-      -- debugPrint $ "UI client" <+> tshow fid <+> "responded."-      case cmdPong of-        ReqUIPong ats -> mapM_ execAtomic ats-        _ -> assert `failure` (fid, cmdPong)--killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()-killAllClients = do-  d <- getDict-  let sendKill fid _ = do-        -- We can't check in sfactionD, because client can be from an old game.-        when (fromEnum fid > 0) $-          sendUpdateUI fid $ RespUpdAtomicUI $ UpdKillExit fid-        sendUpdateAI fid $ RespUpdAtomicAI $ UpdKillExit fid-  mapWithKeyM_ sendKill d---- Global variable for all children threads of the server.-childrenServer :: MVar [Async ()]-{-# NOINLINE childrenServer #-}-childrenServer = unsafePerformIO (newMVar [])---- | Update connections to the new definition of factions.--- Connect to clients in old or newly spawned threads--- that read and write directly to the channels.-updateConn :: (MonadAtomic m, MonadServerReadRequest m)-           => (FactionId-               -> ChanServer ResponseUI RequestUI-               -> IO ())-           -> (FactionId-               -> ChanServer ResponseAI RequestAI-               -> IO ())-           -> m ()-updateConn executorUI executorAI = do-  -- Prepare connections based on factions.-  oldD <- getDict-  let mkChanServer :: IO (ChanServer resp req)-      mkChanServer = do-        responseS <- STM.newTQueueIO-        requestS <- STM.newTQueueIO-        return $! ChanServer{..}-      addConn :: FactionId -> Faction -> IO ConnServerFaction-      addConn fid fact = case EM.lookup fid oldD of-        Just conns -> return conns  -- share old conns and threads-        Nothing | playerUI $ gplayer fact -> do-          connS <- mkChanServer-          connAI <- mkChanServer-          return (Just connS, connAI)-        Nothing -> do-          connAI <- mkChanServer-          return (Nothing, connAI)-  factionD <- getsState sfactionD-  d <- liftIO $ mapWithKeyM addConn factionD-  let newD = d `EM.union` oldD  -- never kill old clients-  putDict newD-  -- Spawn client threads.-  let toSpawn = newD EM.\\ oldD-  let forkUI fid connS =-        forkChild childrenServer $ executorUI fid connS-      forkAI fid connS =-        forkChild childrenServer $ executorAI fid connS-      forkClient fid (connUI, connAI) = do-        -- When a connection is reused, clients are not respawned,-        -- even if UI usage changes, but it works OK thanks to UI faction-        -- clients distinguished by positive FactionId numbers.-        forkAI fid connAI  -- AI clients always needed, e.g., for auto-explore-        maybe skip (forkUI fid) connUI-  liftIO $ mapWithKeyM_ forkClient toSpawn
− Game/LambdaHack/Server/StartServer.hs 
@@ -1,348 +0,0 @@--- | Operations for starting and restarting the game.-module Game.LambdaHack.Server.StartServer-  ( gameReset, reinitGame, initPer, recruitActors, applyDebug, initDebug-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Control.Monad.State as St-import qualified Data.Char as Char-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple (swap)-import qualified System.Random as R--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Flavour-import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.CommonServer-import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.ItemRev-import Game.LambdaHack.Server.ItemServer-import Game.LambdaHack.Server.MonadServer-import Game.LambdaHack.Server.State--initPer :: MonadServer m => m ()-initPer = do-  fovMode <- getsServer $ sfovMode . sdebugSer-  ser <- getServer-  pers <- getsState $ \s -> dungeonPerception (fromMaybe Digital fovMode) s ser-  modifyServer $ \ser1 -> ser1 {sper = pers}--reinitGame :: (MonadAtomic m, MonadServer m) => m ()-reinitGame = do-  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops-  pers <- getsServer sper-  knowMap <- getsServer $ sknowMap . sdebugSer-  -- This state is quite small, fit for transmition to the client.-  -- The biggest part is content, which needs to be updated-  -- at this point to keep clients in sync with server improvements.-  s <- getState-  let defLocal | knowMap = s-               | otherwise = localFromGlobal s-  discoS <- getsServer sdisco-  let sdisco = let f ik = Effect.Identified `elem` ifeature (okind ik)-               in EM.filter f discoS-  sdebugCli <- getsServer $ sdebugCli . sdebugSer-  modeName <- getsServer $ sgameMode . sdebugSer-  broadcastUpdAtomic-    $ \fid -> UpdRestart fid sdisco (pers EM.! fid) defLocal sdebugCli modeName-  populateDungeon--mapFromFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a-mapFromFuns =-  let fromFun f m1 =-        let invAssocs = map (\c -> (f c, c)) [minBound..maxBound]-            m2 = M.fromList invAssocs-        in m2 `M.union` m1-  in foldr fromFun M.empty--lowercase :: Text -> Text-lowercase = T.pack . map Char.toLower . T.unpack--createFactions :: Kind.COps -> Players -> Rnd FactionDict-createFactions Kind.COps{cofaction=Kind.Ops{opick}} players = do-  let rawCreate gplayer@Player{..} = do-        let cmap = mapFromFuns-                     [colorToTeamName, colorToPlainName, colorToFancyName]-            nameoc = lowercase $ head $ T.words playerName-            prefix | playerAI = "Autonomous"-                   | otherwise = "Controlled"-            (gcolor, gname) = case M.lookup nameoc cmap of-              Nothing -> (Color.BrWhite, prefix <+> playerName)-              Just c -> (c, prefix <+> playerName <+> "Team")-        gkind <- fmap (fromMaybe $ assert `failure` playerFaction)-                 $ opick playerFaction (const True)-        let gdipl = EM.empty  -- fixed below-            gquit = Nothing-            gleader = Nothing-            gvictims = EM.empty-            gsha = EM.empty-        return $! Faction{..}-  lUI <- mapM rawCreate $ filter playerUI $ playersList players-  lnoUI <- mapM rawCreate $ filter (not . playerUI) $ playersList players-  let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI)  -- sorted-            ++ zip [toEnum 1..] lUI-      swapIx l =-        let findPlayerName name = find ((name ==) . playerName . gplayer . snd)-            f (name1, name2) =-              case (findPlayerName name1 lFs, findPlayerName name2 lFs) of-                (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2)-                _ -> assert `failure` "unknown faction"-                            `twith` ((name1, name2), lFs)-            ixs = map f l-        -- Only symmetry is ensured, everything else is permitted, e.g.,-        -- a faction in alliance with two others that are at war.-        in ixs ++ map swap ixs-      mkDipl diplMode =-        let f (ix1, ix2) =-              let adj fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)}-              in EM.adjust adj ix1-        in foldr f-      rawFs = EM.fromDistinctAscList lFs-      -- War overrides alliance, so 'warFs' second.-      allianceFs = mkDipl Alliance rawFs (swapIx (playersAlly players))-      warFs = mkDipl War allianceFs (swapIx (playersEnemy players))-  return $! warFs--gameReset :: MonadServer m-          => Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State-gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}}-          sdebug mrandom = do-  dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom-  srandom <- getSetGen $ smainRng sdebug `mplus` mrandom-  scoreTable <- if sfrontendNull $ sdebugCli sdebug then-                  return HighScore.empty-                else-                  restoreScore cops-  sstart <- getsServer sstart  -- copy over from previous game-  sallTime <- getsServer sallTime  -- copy over from previous game-  sheroNames <- getsServer sheroNames  -- copy over from previous game-  let smode = sgameMode sdebug-      rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev,-                  DungeonGen.FreshDungeon)-      rnd = do-        modeKind <- fmap (fromMaybe $ assert `failure` smode)-                    $ opick smode (const True)-        let mode = okind modeKind-            automate p = p {playerAI = True}-            automatePS ps = ps {playersList = map automate $ playersList ps}-            players = if sautomateAll sdebug-                      then automatePS $ mplayers mode-                      else mplayers mode-        faction <- createFactions cops players-        sflavour <- dungeonFlavourMap coitem-        (sdisco, sdiscoRev) <- serverDiscos coitem-        freshDng <- DungeonGen.dungeonGen cops $ mcaves mode-        return (faction, sflavour, sdisco, sdiscoRev, freshDng)-  let (faction, sflavour, sdisco, sdiscoRev, DungeonGen.FreshDungeon{..}) =-        St.evalState rnd dungeonSeed-      defState = defStateGlobal freshDungeon freshTotalDepth-                                faction cops scoreTable-      defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom-                                , srngs = RNGs (Just dungeonSeed)-                                               (Just srandom) }-  putServer defSer-  when (sbenchmark sdebug) resetGameStart-  modifyServer $ \ser -> ser {sdisco, sdiscoRev, sflavour}-  when (sdumpInitRngs sdebug) $ dumpRngs-  return $! defState---- Spawn initial actors. Clients should notice this, to set their leaders.-populateDungeon :: (MonadAtomic m, MonadServer m) => m ()-populateDungeon = do-  cops@Kind.COps{cotile} <- getsState scops-  placeItemsInDungeon-  dungeon <- getsState sdungeon-  factionD <- getsState sfactionD-  sheroNames <- getsServer sheroNames-  let (minD, maxD) =-        case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of-          (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` "empty dungeon" `twith` dungeon-      needInitialCrew = filter ((> 0 ) . playerInitial . gplayer . snd)-                        $ EM.assocs factionD-      getEntryLevel (_, fact) =-        max minD $ min maxD $ toEnum $ playerEntry $ gplayer fact-      arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew-      initialActors lid = do-        lvl <- getLevel lid-        let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew-            representsAlliance (fid2, fact2) =-              not $ any (\(fid3, _) -> fid3 < fid2-                                       && isAllied fact2 fid3) arenaFactions-            arenaAlliances = filter representsAlliance arenaFactions-            placeAlliance ((fid3, _), ppos) =-              mapM_ (\(fid4, fact4) ->-                      if isAllied fact4 fid3 || fid4 == fid3-                      then placeActors lid ((fid4, fact4), ppos)-                      else return ()) arenaFactions-        entryPoss <- rndToAction-                     $ findEntryPoss cops lvl (length arenaAlliances)-        mapM_ placeAlliance $ zip arenaAlliances entryPoss-      placeActors lid ((fid3, fact3), ppos) = do-        time <- getsState $ getLocalTime lid-        let nmult = 1 + fromEnum fid3 `mod` 4  -- always positive-            ntime = timeShift time (timeDeltaScale (Delta timeClip) nmult)-            validTile t = not $ Tile.hasFeature cotile F.NoActor t-        psFree <- getsState $ nearbyFreePoints validTile ppos lid-        let ps = take (playerInitial $ gplayer fact3) $ zip [0..] psFree-        forM_ ps $ \ (n, p) -> do-          go <--            if not $ isHeroFact fact3-            then recruitActors [p] lid ntime fid3-            else do-              let hNames = fromMaybe [] $ EM.lookup fid3 sheroNames-              maid <- addHero fid3 p lid hNames (Just n) ntime-              case maid of-                Nothing -> return False-                Just aid -> do-                  mleader <- getsState $ gleader . (EM.! fid3) . sfactionD-                  when (isNothing mleader) $-                    execUpdAtomic $ UpdLeadFaction fid3 Nothing (Just aid)-                  return True-          unless go $ assert `failure` "can't spawn initial actors"-                             `twith` (lid, (fid3, fact3))-  mapM_ initialActors arenas---- | Spawn actors of any specified faction, friendly or not.--- To be used for initial dungeon population and for the summon effect.-recruitActors :: (MonadAtomic m, MonadServer m)-              => [Point] -> LevelId -> Time -> FactionId-              -> m Bool-recruitActors ps lid time fid = assert (not $ null ps) $ do-  Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops-  fact <- getsState $ (EM.! fid) . sfactionD-  let spawnName = fname $ okind $ gkind fact-  laid <- forM ps $ \ p ->-    if isHeroFact fact-    then addHero fid p lid [] Nothing time-    else addMonster spawnName fid p lid time-  case catMaybes laid of-    [] -> return False-    aid : _ -> do-      mleader <- getsState $ gleader . (EM.! fid) . sfactionD  -- just changed-      when (isNothing mleader) $-        execUpdAtomic $ UpdLeadFaction fid Nothing (Just aid)-      return True---- | Create a new monster on the level, at a given position--- and with a given actor kind and HP.-addMonster :: (MonadAtomic m, MonadServer m)-           => Text -> FactionId -> Point -> LevelId -> Time-           -> m (Maybe ActorId)-addMonster groupName bfid ppos lid time = do-  cops <- getsState scops-  fact <- getsState $ (EM.! bfid) . sfactionD-  pronoun <- if isCivilianFact cops fact-             then rndToAction $ oneOf ["he", "she"]-             else return "it"-  addActor groupName bfid ppos lid id pronoun time---- | Create a new hero on the current level, close to the given position.-addHero :: (MonadAtomic m, MonadServer m)-        => FactionId -> Point -> LevelId -> [(Int, (Text, Text))]-        -> Maybe Int -> Time-        -> m (Maybe ActorId)-addHero bfid ppos lid heroNames mNumber time = do-  Kind.COps{cofaction=Kind.Ops{okind=okind}} <- getsState scops-  Faction{gcolor, gplayer, gkind} <- getsState $ (EM.! bfid) . sfactionD-  let fName = fname $ okind gkind-  mhs <- mapM (\n -> getsState $ \s -> tryFindHeroK s bfid n) [0..9]-  let freeHeroK = elemIndex Nothing mhs-      n = fromMaybe (fromMaybe 100 freeHeroK) mNumber-      bsymbol = if n < 1 || n > 9 then '@' else Char.intToDigit n-      nameFromNumber 0 = ("Captain", "he")-      nameFromNumber k | k `mod` 7 == 0 = ("Heroine" <+> tshow k, "she")-      nameFromNumber k = ("Hero" <+> tshow k, "he")-      (bname, pronoun) | gcolor == Color.BrWhite =-        fromMaybe (nameFromNumber n) $ lookup n heroNames-                       | otherwise =-        let (nameN, pronounN) = nameFromNumber n-        in (playerName gplayer <+> nameN, pronounN)-      tweakBody b = b {bsymbol, bname, bcolor = gcolor}-  addActor fName bfid ppos lid tweakBody pronoun time---- | Find starting postions for all factions. Try to make them distant--- from each other. If only one faction, also move it away from any stairs.-findEntryPoss :: Kind.COps -> Level -> Int -> Rnd [Point]-findEntryPoss Kind.COps{cotile} Level{ltile, lxsize, lysize, lstair} k = do-  let factionDist = max lxsize lysize - 5-      dist poss cmin l _ = all (\pos -> chessDist l pos > cmin) poss-      tryFind _ 0 = return []-      tryFind ps n = do-        np <- findPosTry 1000 ltile  -- try really hard, for skirmish fairness-                (\_ t -> Tile.isWalkable cotile t-                         && (not $ Tile.hasFeature cotile F.NoActor t))-                [ dist ps $ factionDist `div` 2-                , dist ps $ factionDist `div` 3-                , const (Tile.hasFeature cotile F.OftenActor)-                , dist ps $ factionDist `div` 3-                , dist ps $ factionDist `div` 4-                , dist ps $ factionDist `div` 5-                , dist ps $ factionDist `div` 7-                , dist ps $ factionDist `div` 10-                ]-        nps <- tryFind (np : ps) (n - 1)-        return $! np : nps-      stairPoss = fst lstair ++ snd lstair-      middlePos = Point (lxsize `div` 2) (lysize `div` 2)-  assert (k > 0 && factionDist > 0) skip-  case k of-    1 -> tryFind stairPoss k-    2 -> -- Make sure the first faction's pos is not chosen in the middle.-         tryFind [middlePos] k-    _ | k > 2 -> tryFind [] k-    _ -> assert `failure` k--initDebug :: MonadStateRead m => Kind.COps -> DebugModeSer -> m DebugModeSer-initDebug Kind.COps{corule} sdebugSer = do-  let stdRuleset = Kind.stdRuleset corule-  return $!-    (\dbg -> dbg {sfovMode =-        sfovMode dbg `mplus` Just (rfovMode stdRuleset)}) .-    (\dbg -> dbg {ssavePrefixSer =-        ssavePrefixSer dbg `mplus` Just (rsavePrefix stdRuleset)})-    $ sdebugSer---- | Apply debug options that don't need a new game.-applyDebug :: MonadServer m => m ()-applyDebug = do-  DebugModeSer{..} <- getsServer sdebugNxt-  modifyServer $ \ser ->-    ser {sdebugSer = (sdebugSer ser) { sniffIn-                                     , sniffOut-                                     , sallClear-                                     , sfovMode-                                     , sstopAfter-                                     , sdbgMsgSer-                                     , snewGameSer-                                     , sdumpInitRngs-                                     , sdebugCli }}
− Game/LambdaHack/Server/State.hs 
@@ -1,225 +0,0 @@--- | Server and client game state types and operations.-module Game.LambdaHack.Server.State-  ( StateServer(..), emptyStateServer-  , DebugModeSer(..), defDebugModeSer-  , RNGs(..)-  ) where--import Data.Binary-import qualified Data.EnumMap.Strict as EM-import qualified Data.HashMap.Strict as HM-import Data.List-import Data.Text (Text)-import qualified System.Random as R-import System.Time--import Game.LambdaHack.Atomic-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.ItemRev---- | Global, server state.-data StateServer = StateServer-  { sdisco     :: !Discovery     -- ^ full item discoveries data-  , sdiscoRev  :: !DiscoRev      -- ^ reverse disco map, used for item creation-  , sdiscoAE   :: !DiscoAE       -- ^ full item aspect and effect data-  , sitemSeedD :: !ItemSeedDict  -- ^ map from item ids to item seeds-  , sitemRev   :: !ItemRev       -- ^ reverse id map, used for item creation-  , sflavour   :: !FlavourMap    -- ^ association of flavour to items-  , sacounter  :: !ActorId       -- ^ stores next actor index-  , sicounter  :: !ItemId        -- ^ stores next item index-  , sprocessed :: !(EM.EnumMap LevelId Time)-                                 -- ^ actors are processed up to this time-  , sundo      :: ![CmdAtomic]   -- ^ atomic commands performed to date-  , sper       :: !Pers          -- ^ perception of all factions-  , srandom    :: !R.StdGen      -- ^ current random generator-  , srngs      :: !RNGs          -- ^ initial random generators-  , squit      :: !Bool          -- ^ exit the game loop-  , sbkpSave   :: !Bool          -- ^ make backup savefile now-  , sstart     :: !ClockTime     -- ^ this session start time-  , sgstart    :: !ClockTime     -- ^ this game start time-  , sallTime   :: !Time          -- ^ clips since the start of the session-  , sheroNames :: !(EM.EnumMap FactionId [(Int, (Text, Text))])-                                 -- ^ hero names sent by clients-  , sdebugSer  :: !DebugModeSer  -- ^ current debugging mode-  , sdebugNxt  :: !DebugModeSer  -- ^ debugging mode for the next game-  }-  deriving (Show)---- | Debug commands. See 'Server.debugArgs' for the descriptions.-data DebugModeSer = DebugModeSer-  { sknowMap       :: !Bool-  , sknowEvents    :: !Bool-  , sniffIn        :: !Bool-  , sniffOut       :: !Bool-  , sallClear      :: !Bool-  , sgameMode      :: !Text-  , sautomateAll   :: !Bool-  , sstopAfter     :: !(Maybe Int)-  , sbenchmark     :: !Bool-  , sdungeonRng    :: !(Maybe R.StdGen)-  , smainRng       :: !(Maybe R.StdGen)-  , sfovMode       :: !(Maybe FovMode)-  , snewGameSer    :: !Bool-  , sdifficultySer :: !Int-  , sdumpInitRngs  :: !Bool-  , ssavePrefixSer :: !(Maybe String)-  , sdbgMsgSer     :: !Bool-  , sdebugCli      :: !DebugModeCli-  }-  deriving Show--data RNGs = RNGs-  { dungeonRandomGenerator  :: !(Maybe R.StdGen)-  , startingRandomGenerator :: !(Maybe R.StdGen)-  }--instance Show RNGs where-  show RNGs{..} =-    let args = [ maybe "" (\gen -> "--setDungeonRng \"" ++ show gen ++ "\"")-                       dungeonRandomGenerator-               , maybe "" (\gen -> "--setMainRng \"" ++ show gen ++ "\"")-                       startingRandomGenerator ]-    in intercalate " " args---- | Initial, empty game server state.-emptyStateServer :: StateServer-emptyStateServer =-  StateServer-    { sdisco = EM.empty-    , sdiscoRev = EM.empty-    , sdiscoAE = EM.empty-    , sitemSeedD = EM.empty-    , sitemRev = HM.empty-    , sflavour = emptyFlavourMap-    , sacounter = toEnum 0-    , sicounter = toEnum 0-    , sprocessed = EM.empty-    , sundo = []-    , sper = EM.empty-    , srandom = R.mkStdGen 42-    , srngs = RNGs { dungeonRandomGenerator = Nothing-                   , startingRandomGenerator = Nothing }-    , squit = False-    , sbkpSave = False-    , sstart = TOD 0 0-    , sgstart = TOD 0 0-    , sallTime = timeZero-    , sheroNames = EM.empty-    , sdebugSer = defDebugModeSer-    , sdebugNxt = defDebugModeSer-    }--defDebugModeSer :: DebugModeSer-defDebugModeSer = DebugModeSer { sknowMap = False-                               , sknowEvents = False-                               , sniffIn = False-                               , sniffOut = False-                               , sallClear = False-                               , sgameMode = "campaign"-                               , sautomateAll = False-                               , sstopAfter = Nothing-                               , sbenchmark = False-                               , sdungeonRng = Nothing-                               , smainRng = Nothing-                               , sfovMode = Nothing-                               , snewGameSer = False-                               , sdifficultySer = difficultyDefault-                               , sdumpInitRngs = False-                               , ssavePrefixSer = Nothing-                               , sdbgMsgSer = False-                               , sdebugCli = defDebugModeCli-                               }--instance Binary StateServer where-  put StateServer{..} = do-    put sdisco-    put sdiscoRev-    put sdiscoAE-    put sitemSeedD-    put sitemRev-    put sflavour-    put sacounter-    put sicounter-    put sprocessed-    put sundo-    put (show srandom)-    put srngs-    put sheroNames-    put sdebugSer-  get = do-    sdisco <- get-    sdiscoRev <- get-    sdiscoAE <- get-    sitemSeedD <- get-    sitemRev <- get-    sflavour <- get-    sacounter <- get-    sicounter <- get-    sprocessed <- get-    sundo <- get-    g <- get-    srngs <- get-    sheroNames <- get-    sdebugSer <- get-    let srandom = read g-        sper = EM.empty-        squit = False-        sbkpSave = False-        sstart = TOD 0 0-        sgstart = TOD 0 0-        sallTime = timeZero-        sdebugNxt = defDebugModeSer  -- TODO: here difficulty level, etc. from the last session is wiped out-    return $! StateServer{..}--instance Binary DebugModeSer where-  put DebugModeSer{..} = do-    put sknowMap-    put sknowEvents-    put sniffIn-    put sniffOut-    put sallClear-    put sgameMode-    put sautomateAll-    put sdifficultySer-    put sfovMode-    put ssavePrefixSer-    put sdbgMsgSer-    put sdebugCli-  get = do-    sknowMap <- get-    sknowEvents <- get-    sniffIn <- get-    sniffOut <- get-    sallClear <- get-    sgameMode <- get-    sautomateAll <- get-    sdifficultySer <- get-    sfovMode <- get-    ssavePrefixSer <- get-    sdbgMsgSer <- get-    sdebugCli <- get-    let sstopAfter = Nothing-        sbenchmark = False-        sdungeonRng = Nothing-        smainRng = Nothing-        snewGameSer = False-        sdumpInitRngs = False-    return $! DebugModeSer{..}--instance Binary RNGs where-  put RNGs{..} = do-    put (show dungeonRandomGenerator)-    put (show startingRandomGenerator)-  get = do-    dg <- get-    sg <- get-    let dungeonRandomGenerator = read dg-        startingRandomGenerator = read sg-    return $! RNGs{..}
− GameDefinition/Client/UI/Content/KeyKind.hs 
@@ -1,177 +0,0 @@--- | The default game key-command mapping to be used for UI. Can be overriden--- via macros in the config file.-module Client.UI.Content.KeyKind ( standardKeys ) where--import Control.Arrow (first)--import qualified Game.LambdaHack.Client.Key as K-import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.HumanCmd-import qualified Game.LambdaHack.Common.Effect as Effect-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Misc--standardKeys :: KeyKind-standardKeys = KeyKind-  { rhumanCommands = map (first K.mkKM)-      -- All commands are defined here, except some movement and leader picking-      -- commands. All commands are shown on help screens except debug commands-      -- and macros with empty descriptions.-      -- The order below determines the order on the help screens.-      -- Remember to put commands that show information (e.g., enter targeting-      -- mode) first.--      -- Main Menu, which apart of these includes a few extra commands-      [ ("CTRL-x", ([CmdMenu], GameExit))-      , ("CTRL-u", ([CmdMenu], GameRestart "duel"))-      , ("CTRL-k", ([CmdMenu], GameRestart "skirmish"))-      , ("CTRL-m", ([CmdMenu], GameRestart "ambush"))-      , ("CTRL-b", ([CmdMenu], GameRestart "battle"))-      , ("CTRL-a", ([CmdMenu], GameRestart "campaign"))-      , ("CTRL-d", ([CmdMenu], GameDifficultyCycle))--      -- Movement and terrain alteration-      , ("less", ([CmdMove, CmdMinimal], TriggerTile-           [ TriggerFeature { verb = "ascend"-                            , object = "a level"-                            , feature = F.Cause (Effect.Ascend 1) }-           , TriggerFeature { verb = "escape"-                            , object = "dungeon"-                            , feature = F.Cause (Effect.Escape 1) } ]))-      , ("CTRL-less", ([CmdMove], TriggerTile-           [ TriggerFeature { verb = "ascend"-                            , object = "10 levels"-                            , feature = F.Cause (Effect.Ascend 10) } ]))-      , ("greater", ([CmdMove, CmdMinimal], TriggerTile-           [ TriggerFeature { verb = "descend"-                            , object = "a level"-                            , feature = F.Cause (Effect.Ascend (-1)) }-           , TriggerFeature { verb = "escape"-                            , object = "dungeon"-                            , feature = F.Cause (Effect.Escape (-1)) } ]))-      , ("CTRL-greater", ([CmdMove], TriggerTile-           [ TriggerFeature { verb = "descend"-                            , object = "10 levels"-                            , feature = F.Cause (Effect.Ascend (-10)) } ]))-      , ("semicolon", ([CmdMove], StepToTarget))-      , ("colon", ([CmdMove], Macro "go to target for 100 steps"-                                    ["semicolon", "V"]))-      , ("CTRL-colon", ([CmdMove], Macro "go to target for 10 steps"-                                         ["semicolon", "CTRL-V"]))-      , ("x", ([CmdMove], Macro "explore the closest unknown spot"-                                [ "BackSpace"-                                , "CTRL-question", "semicolon", "V" ]))-      , ("X", ([CmdMove], Macro "autoexplore 100 times"-                                [ "BackSpace"-                                , "'", "CTRL-question", "semicolon", "'"-                                , "V" ]))-      , ("CTRL-X", ([CmdMove], Macro "autoexplore 10 times"-                                      [ "BackSpace"-                                      , "'", "CTRL-question", "semicolon", "'"-                                      , "CTRL-V" ]))-      , ("R", ([CmdMove], Macro "rest (wait 100 times)"-                                ["KP_Begin", "V"]))-      , ("CTRL-R", ([CmdMove], Macro "rest (wait 10 times)"-                                     ["KP_Begin", "CTRL-V"]))-      , ("c", ([CmdMove], AlterDir-           [ AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "vertical closed door Lit" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "horizontal closed door Lit" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "vertical closed door Dark" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "horizontal closed door Dark" }-           ]))-      , ("period", ([CmdMove], Macro "" ["KP_Begin"]))-      , ("i", ([CmdMove], Macro "" ["KP_Begin"]))--      -- Item use-      , ("E", ([CmdItem], DescribeItem CEqp))-      , ("P", ([CmdItem], DescribeItem CInv))-      , ("S", ([CmdItem], DescribeItem CSha))-      , ("G", ([CmdItem], DescribeItem CGround))-      , ("A", ([CmdItem], AllOwned))-      , ("g", ([CmdItem, CmdMinimal],-               MoveItem [CGround] CEqp "get" "an item" True))-      , ("d", ([CmdItem], MoveItem [CEqp, CInv, CSha] CGround-                                   "drop" "an item" False))-      , ("e", ([CmdItem], MoveItem [CInv, CSha] CEqp-                                   "equip" "an item" False))-      , ("p", ([CmdItem], MoveItem [CEqp, CSha] CInv-                                   "pack" "an item into inventory backpack"-                                   False))-      , ("s", ([CmdItem], MoveItem [CEqp, CInv] CSha-                                   "stash" "and share an item" False))-      , ("a", ([CmdItem, CmdMinimal], Apply-           [ ApplyItem { verb = "activate"-                       , object = "applicable item"-                       , symbol = ' ' }-           , ApplyItem { verb = "quaff"-                       , object = "potion"-                       , symbol = '!' }-           , ApplyItem { verb = "read"-                       , object = "scroll"-                       , symbol = '?' }-           ]))-      , ("q", ([CmdItem], Apply [ApplyItem { verb = "quaff"-                                           , object = "potion"-                                           , symbol = '!' }]))-      , ("r", ([CmdItem], Apply [ApplyItem { verb = "read"-                                           , object = "scroll"-                                           , symbol = '?' }]))-      , ("f", ([CmdItem, CmdMinimal], Project-           [ApplyItem { verb = "fling"-                      , object = "projectable item"-                      , symbol = ' ' }]))-      , ("t", ([CmdItem], Project [ApplyItem { verb = "throw"-                                             , object = "missile"-                                             , symbol = '|' }]))-      , ("z", ([CmdItem], Project [ApplyItem { verb = "zap"-                                             , object = "wand"-                                             , symbol = '/' }]))--      -- Targeting-      , ("KP_Multiply", ([CmdTgt, CmdMinimal], TgtEnemy))-      , ("backslash", ([CmdTgt], Macro "" ["KP_Multiply"]))-      , ("slash", ([CmdTgt], TgtFloor))-      , ("plus", ([CmdTgt], EpsIncr True))-      , ("minus", ([CmdTgt], EpsIncr False))-      , ("BackSpace", ([CmdTgt], TgtClear))-      , ("CTRL-question", ([CmdTgt], TgtUnknown))-      , ("CTRL-I", ([CmdTgt], TgtItem))-      , ("CTRL-braceleft", ([CmdTgt], TgtStair True))-      , ("CTRL-braceright", ([CmdTgt], TgtStair False))--      -- Automation-      , ("equal", ([CmdAuto], SelectActor))-      , ("underscore", ([CmdAuto], SelectNone))-      , ("v", ([CmdAuto], Repeat 1))-      , ("V", ([CmdAuto], Repeat 100))-      , ("CTRL-v", ([CmdAuto], Repeat 1000))-      , ("CTRL-V", ([CmdAuto], Repeat 10))-      , ("apostrophe", ([CmdAuto], Record))-      , ("CTRL-A", ([CmdAuto], Automate))--      -- Assorted-      , ("question", ([CmdMeta], Help))-      , ("D", ([CmdMeta], History))-      , ("T", ([CmdMeta], MarkSuspect))-      , ("Z", ([CmdMeta], MarkVision))-      , ("C", ([CmdMeta], MarkSmell))-      , ("Tab", ([CmdMeta], MemberCycle))-      , ("ISO_Left_Tab", ([CmdMeta], MemberBack))-      , ("space", ([CmdMeta], Clear))-      , ("Escape", ([CmdMeta, CmdMinimal], Cancel))-      , ("Return", ([CmdMeta], Accept))--      -- Debug and others not to display in help screens-      , ("CTRL-s", ([CmdDebug], GameSave))-      , ("CTRL-f", ([CmdDebug], GameRestart "safari"))-      , ("CTRL-e", ([CmdDebug], GameRestart "defense"))-      ]-  }
GameDefinition/Content/CaveKind.hs view
@@ -1,174 +1,578 @@--- | Cave layouts for LambdaHack.-module Content.CaveKind ( cdefs ) where+-- | Definitions of of cave kinds. Every level in the game is an instantiated+-- cave kind.+module Content.CaveKind+  ( -- * Group name patterns+    pattern CAVE_ROGUE, pattern CAVE_ARENA, pattern CAVE_SMOKING, pattern CAVE_LABORATORY, pattern CAVE_NOISE, pattern CAVE_MINE, pattern CAVE_EMPTY, pattern CAVE_SHALLOW_ROGUE, pattern CAVE_OUTERMOST, pattern CAVE_RAID, pattern CAVE_BRAWL, pattern CAVE_SHOOTOUT, pattern CAVE_HUNT, pattern CAVE_FLIGHT, pattern CAVE_ZOO, pattern CAVE_AMBUSH, pattern CAVE_BATTLE, pattern CAVE_SAFARI_1, pattern CAVE_SAFARI_2, pattern CAVE_SAFARI_3+  , groupNamesSingleton, groupNames+  , -- * Content+    content+  ) where +import Prelude ()++import Game.LambdaHack.Core.Prelude+ import Data.Ratio -import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Dice-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.CaveKind+import           Game.LambdaHack.Content.CaveKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.TileKind+import           Game.LambdaHack.Core.Dice+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.DefsInternal -cdefs :: ContentDef CaveKind-cdefs = ContentDef-  { getSymbol = csymbol-  , getName = cname-  , getFreq = cfreq-  , validate = validateCaveKind-  , content =-      [rogue, arena, empty, noise, battle, skirmish, ambush, safari1, safari2, safari3]-  }-rogue,        arena, empty, noise, battle, skirmish, ambush, safari1, safari2, safari3 :: CaveKind+import Content.ItemKind hiding (content, groupNames, groupNamesSingleton)+import Content.ItemKindActor+import Content.PlaceKind hiding (content, groupNames, groupNamesSingleton)+import Content.TileKind hiding (content, groupNames, groupNamesSingleton) +-- * Group name patterns++groupNamesSingleton :: [GroupName CaveKind]+groupNamesSingleton = []++groupNames :: [GroupName CaveKind]+groupNames =+       [CAVE_ROGUE, CAVE_ARENA, CAVE_SMOKING, CAVE_LABORATORY, CAVE_NOISE, CAVE_MINE, CAVE_EMPTY, CAVE_SHALLOW_ROGUE, CAVE_OUTERMOST, CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_FLIGHT, CAVE_ZOO, CAVE_AMBUSH, CAVE_BATTLE, CAVE_SAFARI_1, CAVE_SAFARI_2, CAVE_SAFARI_3]++pattern CAVE_ROGUE, CAVE_ARENA, CAVE_SMOKING, CAVE_LABORATORY, CAVE_NOISE, CAVE_MINE, CAVE_EMPTY, CAVE_SHALLOW_ROGUE, CAVE_OUTERMOST, CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_FLIGHT, CAVE_ZOO, CAVE_AMBUSH, CAVE_BATTLE, CAVE_SAFARI_1, CAVE_SAFARI_2, CAVE_SAFARI_3 :: GroupName CaveKind++pattern CAVE_ROGUE = GroupName "caveRogue"+pattern CAVE_ARENA = GroupName "caveArena"+pattern CAVE_SMOKING = GroupName "caveSmoking"+pattern CAVE_LABORATORY = GroupName "caveLaboratory"+pattern CAVE_NOISE = GroupName "caveNoise"+pattern CAVE_MINE = GroupName "caveMine"+pattern CAVE_EMPTY = GroupName "caveEmpty"+pattern CAVE_SHALLOW_ROGUE = GroupName "caveShallowRogue"+pattern CAVE_OUTERMOST = GroupName "caveOutermost"+pattern CAVE_RAID = GroupName "caveRaid"+pattern CAVE_BRAWL = GroupName "caveBrawl"+pattern CAVE_SHOOTOUT = GroupName "caveShootout"+pattern CAVE_HUNT = GroupName "caveHunt"+pattern CAVE_FLIGHT = GroupName "caveFlight"+pattern CAVE_ZOO = GroupName "caveZoo"+pattern CAVE_AMBUSH = GroupName "caveAmbush"+pattern CAVE_BATTLE = GroupName "caveBattle"+pattern CAVE_SAFARI_1 = GroupName "caveSafari1"+pattern CAVE_SAFARI_2 = GroupName "caveSafari2"+pattern CAVE_SAFARI_3 = GroupName "caveSafari3"++-- * Content++content :: [CaveKind]+content =+  [rogue, arena, smoking, laboratory, noise, mine, empty, outermost, shallowRogue, raid, brawl, shootout, hunt, flight, zoo, ambush, battle, safari1, safari2, safari3]++rogue,    arena, smoking, laboratory, noise, mine, empty, outermost, shallowRogue, raid, brawl, shootout, hunt, flight, zoo, ambush, battle, safari1, safari2, safari3 :: CaveKind++-- * Underground caves; most of mediocre height and size+ rogue = CaveKind-  { csymbol       = 'R'-  , cname         = "A maze of twisty passages"-  , cfreq         = [("dng", 100), ("caveRogue", 1)]-  , cxsize        = fst normalLevelBound + 1-  , cysize        = snd normalLevelBound + 1-  , cgrid         = DiceXY (3 * d 2) (d 2 + 2)-  , cminPlaceSize = DiceXY (2 * d 2 + 2) 4-  , cmaxPlaceSize = DiceXY 15 10-  , cdarkChance   = d 54 + dl 20-  , cnightChance  = 51-  , cauxConnects  = 1%3+  { cname         = "A maze of twisty passages"+  , cfreq         = [(DEFAULT_RANDOM, 100), (CAVE_ROGUE, 1)]+  , cXminSize     = 80+  , cYminSize     = 21+  , ccellSize     = DiceXY (2 `d` 4 + 10) 6+  , cminPlaceSize = DiceXY (2 `d` 2 + 4) 5+  , cmaxPlaceSize = DiceXY 16 40+  , cdarkOdds     = 1 `d` 54 + 1 `dL` 20+      -- most rooms lit, to compensate for dark corridors+  , cnightOdds    = 51  -- always night+  , cauxConnects  = 1%2   , cmaxVoid      = 1%6-  , cminStairDist = 30-  , cdoorChance   = 1%2-  , copenChance   = 1%10-  , chidden       = 8-  , cactorFreq    = [("monster", 50), ("animal", 50)]-  , citemNum      = 10 * d 2-  , citemFreq     = [("useful", 70), ("treasure", 30)]-  , cplaceFreq    = [("rogue", 100)]+  , cdoorChance   = 3%4+  , copenChance   = 1%5+  , chidden       = 7+  , cactorCoeff   = 70  -- the maze requires time to explore+  , cactorFreq    = [(MONSTER, 60), (ANIMAL, 40)]+  , citemNum      = 6 `d` 5 + 10 - 10 `dL` 1+      -- deep down quality over quantity; generally quite random,+      -- for interesting replays at the cost of unreliable balance+  , citemFreq     = [(IK.COMMON_ITEM, 40), (IK.TREASURE, 60)]+  , cplaceFreq    = [(ROGUE, 1)]   , cpassable     = False-  , cdefTile        = "fillerWall"-  , cdarkCorTile    = "floorCorridorDark"-  , clitCorTile     = "floorCorridorLit"-  , cfillerTile     = "fillerWall"-  , couterFenceTile = "basic outer fence"-  , clegendDarkTile = "legendDark"-  , clegendLitTile  = "legendLit"-  }+  , clabyrinth    = False+  , cdefTile      = FILLER_WALL+  , cdarkCorTile  = FLOOR_CORRIDOR_DARK+  , clitCorTile   = FLOOR_CORRIDOR_LIT+  , cwallTile     = FILLER_WALL+  , ccornerTile   = FILLER_WALL+  , cfenceTileN   = S_BASIC_OUTER_FENCE+  , cfenceTileE   = S_BASIC_OUTER_FENCE+  , cfenceTileS   = S_BASIC_OUTER_FENCE+  , cfenceTileW   = S_BASIC_OUTER_FENCE+  , cfenceApart   = False+  , cminStairDist = 20+  , cmaxStairsNum = 1 + 1 `d` 2+  , cescapeFreq   = []+  , cstairFreq    = [ (WALLED_STAIRCASE, 50), (OPEN_STAIRCASE, 50)+                    , (TINY_STAIRCASE, 1) ]+  , cstairAllowed = []+  , cskip         = []+  , cinitSleep    = InitSleepPermitted+  , cdesc         = "Winding tunnels stretch into the dark."+  }  -- no lit corridors cave alternative, since both lit # and . look bad here arena = rogue-  { csymbol       = 'A'-  , cname         = "Underground city"-  , cfreq         = [("dng", 30), ("caveArena", 1)]-  , cgrid         = DiceXY (2 * d 2) (2 * d 2)-  , cminPlaceSize = DiceXY (2 * d 2 + 3) 4-  , cdarkChance   = d 80 + dl 60-  , cnightChance  = 0-  , cmaxVoid      = 1%3-  , chidden       = 1000-  , cactorFreq    = [("monster", 70), ("animal", 30)]-  , citemNum      = 8 * d 2  -- few rooms-  , cpassable     = True-  , cdefTile      = "arenaSet"-  , cdarkCorTile  = "trailLit"  -- let trails give off light-  , clitCorTile   = "trailLit"-  }-empty = rogue-  { csymbol       = 'E'-  , cname         = "Tall cavern"-  , cfreq         = [("dng", 20), ("caveEmpty", 1)]-  , cgrid         = DiceXY (d 2 + 1) 1-  , cminPlaceSize = DiceXY 10 10-  , cmaxPlaceSize = DiceXY 24 12-  , cdarkChance   = d 80 + dl 80-  , cnightChance  = 0+  { cname         = "Dusty underground library"+  , cfreq         = [(DEFAULT_RANDOM, 60), (CAVE_ARENA, 1)]+  , cXminSize     = 50+  , cYminSize     = 21+  , ccellSize     = DiceXY (3 `d` 3 + 17) (1 `d` 3 + 4)+  , cminPlaceSize = DiceXY (2 `d` 2 + 4) 6+  , cmaxPlaceSize = DiceXY 16 12+  , cdarkOdds     = 49 + 1 `d` 10  -- almost all rooms dark (1 in 10 lit)+  -- Light is not too deadly, because not many obstructions and so+  -- foes visible from far away and few foes have ranged combat+  -- at shallow depth.+  , cnightOdds    = 0  -- always day   , cauxConnects  = 1-  , cmaxVoid      = 1%2-  , cminStairDist = 50-  , chidden       = 1000-  , cactorFreq    = [("monster", 10), ("animal", 90)]-  , citemNum      = 6 * d 2  -- few rooms+  , cmaxVoid      = 1%8+  , chidden       = 0+  , cactorCoeff   = 70  -- small open level, don't rush the player+  , cactorFreq    = [(MONSTER, 30), (ANIMAL, 70)]+  , citemNum      = 4 `d` 5  -- few rooms+  , citemFreq     = [ (IK.COMMON_ITEM, 20), (IK.TREASURE, 40)+                    , (IK.ANY_SCROLL, 40) ]+  , cplaceFreq    = [(ARENA, 1)]   , cpassable     = True-  , cdefTile      = "emptySet"-  , cdarkCorTile  = "floorArenaDark"-  , clitCorTile   = "floorArenaLit"+  , cdefTile      = ARENA_SET_LIT+  , cdarkCorTile  = TRAIL_LIT  -- let trails give off light+  , clitCorTile   = TRAIL_LIT  -- may be rolled different than the above+  , cminStairDist = 15+  , cmaxStairsNum = 1 `d` 2+  , cstairFreq    = [ (WALLED_STAIRCASE, 20), (CLOSED_STAIRCASE, 80)+                    , (TINY_STAIRCASE, 1) ]+  , cinitSleep    = InitSleepAlways+  , cdesc         = "The shelves groan with dusty books and tattered scrolls. Subtle snoring can be heard from a distance."   }+smoking = arena+  { cname         = "Smoking rooms"+  , cfreq         = [(CAVE_SMOKING, 1)]+  , cdarkOdds     = 41 + 1 `d` 10  -- almost all rooms lit (1 in 10 dark)+  -- Trails provide enough light for fun stealth.+  , cnightOdds    = 51  -- always night+  , citemNum      = 6 `d` 5  -- rare, so make it exciting+  , citemFreq     = [(IK.COMMON_ITEM, 20), (IK.TREASURE, 40), (IK.ANY_GLASS, 40)]+  , cdefTile      = ARENA_SET_DARK+  , cdesc         = "Velvet couches exude the strong smell of tobacco."+  }+laboratory = rogue+  { cname         = "Burnt laboratory"+  , cfreq         = [(CAVE_LABORATORY, 1)]+  , cXminSize     = 60+  , cYminSize     = 21+  , ccellSize     = DiceXY (1 `d` 2 + 5) 6+  , cminPlaceSize = DiceXY 7 5+  , cmaxPlaceSize = DiceXY 10 40+  , cnightOdds    = 0  -- always day so that the corridor smoke is lit+  , cauxConnects  = 1%5+  , cmaxVoid      = 1%10+  , cdoorChance   = 1+  , copenChance   = 1%2+  , cactorFreq    = [(MONSTER, 30), (ANIMAL, 70)]+  , citemNum      = 6 `d` 5  -- reward difficulty+  , citemFreq     = [ (IK.COMMON_ITEM, 20), (IK.TREASURE, 40)+                    , (IK.EXPLOSIVE, 40) ]+  , cplaceFreq    = [(LABORATORY, 1)]+  , cdarkCorTile  = LAB_TRAIL_LIT  -- let lab smoke give off light always+  , clitCorTile   = LAB_TRAIL_LIT+  , cmaxStairsNum = 2+  , cstairFreq    = [ (WALLED_STAIRCASE, 50), (OPEN_STAIRCASE, 50)+                    , (TINY_STAIRCASE, 1) ]+  , cdesc         = "Shattered glassware and the sharp scent of spilt chemicals show that something terrible happened here."+  } noise = rogue-  { csymbol       = 'N'-  , cname         = "Glittering cave"-  , cfreq         = [("dng", 10), ("caveNoise", 1)]-  , cgrid         = DiceXY 3 3-  , cminPlaceSize = DiceXY 8 4-  , cmaxPlaceSize = DiceXY 24 12-  , cnightChance  = d 100-  , cauxConnects  = 0-  , cmaxVoid      = 0-  , chidden       = 1000-  , cactorFreq    = [("monster", 80), ("animal", 20)]-  , citemNum      = 12 * d 2  -- an incentive to explore the labyrinth+  { cname         = "Leaky burrowed sediment"+  , cfreq         = [(DEFAULT_RANDOM, 30), (CAVE_NOISE, 1)]+  , cXminSize     = 50+  , cYminSize     = 21+  , ccellSize     = DiceXY (3 `d` 5 + 12) 6+  , cminPlaceSize = DiceXY 8 5+  , cmaxPlaceSize = DiceXY 20 20+  , cdarkOdds     = 51+  -- Light is deadly, because nowhere to hide and pillars enable spawning+  -- very close to heroes.+  , cnightOdds    = 0  -- harder variant, but looks cheerful+  , cauxConnects  = 1%10+  , cmaxVoid      = 1%100+  , cdoorChance   = 1  -- to avoid lit quasi-door tiles+  , chidden       = 0+  , cactorCoeff   = 100  -- the maze requires time to explore; also, small+  , cactorFreq    = [(MONSTER, 80), (ANIMAL, 20)]+  , citemNum      = 6 `d` 5  -- an incentive to explore the labyrinth   , cpassable     = True-  , cplaceFreq    = [("noise", 50), ("rogue", 50)]-  , cdefTile      = "noiseSet"-  , cdarkCorTile  = "floorArenaDark"-  , clitCorTile   = "floorArenaLit"+  , cplaceFreq    = [(NOISE, 1)]+  , clabyrinth    = True+  , cdefTile      = NOISE_SET_LIT+  , cfenceApart   = True  -- ensures no cut-off parts from collapsed+  , cdarkCorTile  = DAMP_FLOOR_DARK+  , clitCorTile   = DAMP_FLOOR_LIT+  , cminStairDist = 15+  , cstairFreq    = [ (CLOSED_STAIRCASE, 50), (OPEN_STAIRCASE, 50)+                    , (TINY_STAIRCASE, 1) ]+  , cinitSleep    = InitSleepBanned+  , cdesc         = "Soon, these passages will be swallowed up by the mud."   }-battle = rogue  -- few lights and many solids, to help the less numerous heroes-  { csymbol       = 'B'-  , cname         = "Old battle ground"-  , cfreq         = [("caveBattle", 1)]-  , cgrid         = DiceXY (2 * d 2 + 1) 3+mine = noise+  { cname         = "Frozen derelict mine"+  , cfreq         = [(CAVE_MINE, 1)]+  , cnightOdds    = 51  -- easier variant, but looks sinister+  , citemNum      = 10 `d` 4  -- an incentive to explore the final labyrinth+  , citemFreq     = [(IK.COMMON_ITEM, 20), (GEM, 20)]+                      -- can't be "valuable" or template items generated+  , cplaceFreq    = [(NOISE, 1), (MINE, 99)]+  , clabyrinth    = True+  , cdefTile      = POWER_SET_DARK+  , cstairFreq    = [ (GATED_CLOSED_STAIRCASE, 50)+                    , (GATED_OPEN_STAIRCASE, 50)+                    , (GATED_TINY_STAIRCASE, 1) ]+  , cinitSleep    = InitSleepBanned+  , cdesc         = "Pillars of shining ice create a frozen labyrinth."+  }+empty = rogue+  { cname         = "Tall cavern"+  , cfreq         = [(CAVE_EMPTY, 1)]+  , ccellSize     = DiceXY (2 `d` 2 + 11) (1 `d` 2 + 8)+  , cminPlaceSize = DiceXY 13 11+  , cmaxPlaceSize = DiceXY 37 31  -- favour large rooms+  , cdarkOdds     = 1 `d` 100 + 1 `dL` 100+  , cnightOdds    = 0  -- always day+  , cauxConnects  = 3%2+  , cmaxVoid      = 0  -- too few rooms to have void and fog common anyway+  , cdoorChance   = 0+  , copenChance   = 0+  , chidden       = 0+  , cactorCoeff   = 8+  , cactorFreq    = [(ANIMAL, 10), (IMMOBILE_ANIMAL, 90)]+      -- The healing geysers on lvl 3 act like HP resets. Needed to avoid+      -- cascading failure, if the particular starting conditions were+      -- very hard. Items are not reset, even if they are bad, which provides+      -- enough of a continuity. Gyesers on lvl 3 are not OP and can't be+      -- abused, because they spawn less and less often and also HP doesn't+      -- effectively accumulate over max.+  , citemNum      = 4 `d` 5  -- few rooms and geysers are the boon+  , cplaceFreq    = [(EMPTY, 1)]+  , cpassable     = True+  , cdefTile      = EMPTY_SET_LIT+  , cdarkCorTile  = FLOOR_ARENA_DARK+  , clitCorTile   = FLOOR_ARENA_LIT+  , cminStairDist = 30+  , cmaxStairsNum = 1+  , cstairFreq    = [ (WALLED_STAIRCASE, 20), (CLOSED_STAIRCASE, 80)+                    , (TINY_STAIRCASE, 1) ]+  , cdesc         = "Swirls of warm fog fill the air, the hiss of geysers sounding all around."+  }+outermost = shallowRogue+  { cname         = "Cave entrance"+  , cfreq         = [(CAVE_OUTERMOST, 100)]+  , cXminSize     = 40+  , cYminSize     = 21+  , cdarkOdds     = 0  -- all rooms lit, for a gentle start+  , cactorCoeff   = 100  -- already animals start there; also, pity on the noob+  , cactorFreq    = filter ((/= MONSTER) . fst) $ cactorFreq rogue+  , citemNum      = 12 `d` 2  -- lure them in with loot; relatively consisten+  , citemFreq     = filter ((/= IK.TREASURE) . fst) $ citemFreq rogue+  , cminStairDist = 10  -- distance from the escape+  , cmaxStairsNum = 1  -- simplify at the start+  , cescapeFreq   = [(INDOOR_ESCAPE_UP, 1)]+  , cdesc         = "This close to the surface, the sunlight still illuminates the dungeon."+  }+shallowRogue = rogue+  { cfreq         = [(CAVE_SHALLOW_ROGUE, 100)]+  , cXminSize     = 60+  , cYminSize     = 21+  , cmaxStairsNum = 1  -- simplify at the start+  , cdesc         = "The snorts and grunts of savage beasts can be clearly heard."+  }++-- * Overground "caves"; no story-wise limits wrt height and size++raid = rogue+  { cname         = "Typing den"+  , cfreq         = [(CAVE_RAID, 1)]+  , cXminSize     = 50+  , cYminSize     = 21+  , ccellSize     = DiceXY (2 `d` 4 + 6) 6+  , cminPlaceSize = DiceXY (2 `d` 2 + 4) 5+  , cmaxPlaceSize = DiceXY 16 20+  , cdarkOdds     = 0  -- all rooms lit, for a gentle start+  , cmaxVoid      = 1%10+  , cdoorChance   = 1  -- make sure enemies not seen on turn 1+  , copenChance   = 0  -- make sure enemies not seen on turn 1+  , cactorCoeff   = 300  -- deep level with no kit, so slow spawning+  , cactorFreq    = [(ANIMAL, 100)]+  , citemNum      = 18  -- first tutorial mode, so make it consistent+  , citemFreq     = [ (IK.COMMON_ITEM, 100), (IK.S_CURRENCY, 500)+                    , (STARTING_WEAPON, 100) ]+  , cmaxStairsNum = 0+  , cescapeFreq   = [(INDOOR_ESCAPE_UP, 1)]+  , cstairFreq    = []+  , cstairAllowed = []+  , cdesc         = "Mold spreads across the walls and scuttling sounds can be heard in the distance."+  }+brawl = rogue  -- many random solid tiles, to break LOS, since it's a day+               -- and this scenario is not focused on ranged combat;+               -- also, sanctuaries against missiles in shadow under trees+  { cname         = "Sunny woodland"+  , cfreq         = [(CAVE_BRAWL, 1)]+  , cXminSize     = 60+  , cYminSize     = 21+  , ccellSize     = DiceXY (2 `d` 5 + 5) 6   , cminPlaceSize = DiceXY 3 3-  , cmaxPlaceSize = DiceXY 9 7-  , cdarkChance   = 0-  , cnightChance  = 100-  , cdoorChance   = 2%10-  , copenChance   = 9%10-  , chidden       = 1000+  , cmaxPlaceSize = DiceXY 7 5+  , cdarkOdds     = 51+  , cnightOdds    = 0+  , cdoorChance   = 1+  , copenChance   = 0+  , chidden       = 0   , cactorFreq    = []-  , citemNum      = 12 * d 2-  , citemFreq     = [("useful", 100)]-  , cplaceFreq    = [("battle", 50), ("rogue", 50)]+  , citemNum      = 4 `d` 6+  , citemFreq     = [ (IK.COMMON_ITEM, 50), (STARTING_WEAPON, 100)+                    , (STARTING_ARMOR, 100) ]+  , cplaceFreq    = [(BRAWL, 1)]   , cpassable     = True-  , cdefTile      = "battleSet"-  , cdarkCorTile  = "trailLit"  -- let trails give off light-  , clitCorTile   = "trailLit"+  , cdefTile      = BRAWL_SET_LIT+  , cdarkCorTile  = DIRT_LIT+  , clitCorTile   = DIRT_LIT+  , cstairFreq    = []+  , cfenceTileN   = OUTDOOR_OUTER_FENCE+  , cfenceTileE   = OUTDOOR_OUTER_FENCE+  , cfenceTileS   = OUTDOOR_OUTER_FENCE+  , cfenceTileW   = OUTDOOR_OUTER_FENCE+  , cmaxStairsNum = 0+  , cdesc         = "Sunlight falls through the trees and dapples on the ground."   }-skirmish = rogue  -- many random solid tiles, to break LOS, since it's a day-  { csymbol       = 'S'-  , cname         = "Sunny woodland"-  , cfreq         = [("caveSkirmish", 1)]-  , cgrid         = DiceXY (2 * d 2 + 2) (d 2 + 2)+shootout = rogue  -- a scenario with strong missiles;+                  -- few solid tiles, but only translucent tiles or walkable+                  -- opaque tiles, to make scouting and sniping more interesting+                  -- and to avoid obstructing view too much, since this+                  -- scenario is about ranged combat at long range+  { cname         = "Misty meadow"+  , cfreq         = [(CAVE_SHOOTOUT, 1)]+  , ccellSize     = DiceXY (1 `d` 2 + 6) 6   , cminPlaceSize = DiceXY 3 3-  , cmaxPlaceSize = DiceXY 7 5-  , cdarkChance   = 100-  , cnightChance  = 0+  , cmaxPlaceSize = DiceXY 4 4+  , cdarkOdds     = 51+  , cnightOdds    = 0+  , cauxConnects  = 1%10   , cdoorChance   = 1   , copenChance   = 0-  , chidden       = 1000+  , chidden       = 0   , cactorFreq    = []-  , citemNum      = 12 * d 2-  , citemFreq     = [("useful", 100)]-  , cplaceFreq    = [("skirmish", 60), ("rogue", 40)]+  , citemNum      = 5 `d` 16+                      -- less items in inventory, more to be picked up,+                      -- to reward explorer and aggressor and punish camper+  , citemFreq     = [ (IK.COMMON_ITEM, 30)+                    , (ANY_ARROW, 400), (HARPOON, 300), (IK.EXPLOSIVE, 50) ]+                      -- Many consumable buffs are needed in symmetric maps+                      -- so that aggressor prepares them in advance and camper+                      -- needs to waste initial turns to buff for the defence.+  , cplaceFreq    = [(SHOOTOUT, 1)]   , cpassable     = True-  , cdefTile      = "skirmishSet"-  , cdarkCorTile  = "floorArenaLit"-  , clitCorTile   = "floorArenaLit"+  , cdefTile      = SHOOTOUT_SET_LIT+  , cdarkCorTile  = DIRT_LIT+  , clitCorTile   = DIRT_LIT+  , cstairFreq    = []+  , cfenceTileN   = OUTDOOR_OUTER_FENCE+  , cfenceTileE   = OUTDOOR_OUTER_FENCE+  , cfenceTileS   = OUTDOOR_OUTER_FENCE+  , cfenceTileW   = OUTDOOR_OUTER_FENCE+  , cmaxStairsNum = 0+  , cdesc         = "The warmth has released fog and the wind brooms it away."   }-ambush = rogue  -- lots of lights, to give a chance to snipe-  { csymbol       = 'M'-  , cname         = "Public garden at night"-  , cfreq         = [("caveAmbush", 1)]-  , cgrid         = DiceXY (2 * d 2 + 3) (d 2 + 2)+hunt = rogue  -- a scenario with strong missiles for ranged and shade for melee+  { cname         = "Afternoon swamp"+  , cfreq         = [(CAVE_HUNT, 1)]+  , ccellSize     = DiceXY (1 `d` 2 + 6) 6   , cminPlaceSize = DiceXY 3 3-  , cmaxPlaceSize = DiceXY 5 5-  , cdarkChance   = 0-  , cnightChance  = 100-  , cauxConnects  = 1-  , cdoorChance   = 1%10+  , cmaxPlaceSize = DiceXY 4 4+  , cdarkOdds     = 51+  , cnightOdds    = 0+  , cauxConnects  = 1%10+  , cdoorChance   = 1+  , copenChance   = 0+  , chidden       = 0+  , cactorCoeff   = 400  -- spawn slowly+  , cactorFreq    = [(INSECT, 100)]+  , citemNum      = 5 `d` 10+  , citemFreq     = [ (IK.COMMON_ITEM, 30)+                    , (ANY_ARROW, 400), (HARPOON, 300), (IK.EXPLOSIVE, 50) ]+  , cplaceFreq    = [(BRAWL, 50), (SHOOTOUT, 100)]+  , cpassable     = True+  , cdefTile      = SHOOTOUT_SET_LIT+  , cdarkCorTile  = DIRT_LIT+  , clitCorTile   = DIRT_LIT+  , cstairFreq    = []+  , cfenceTileN   = OUTDOOR_OUTER_FENCE+  , cfenceTileE   = OUTDOOR_OUTER_FENCE+  , cfenceTileS   = OUTDOOR_OUTER_FENCE+  , cfenceTileW   = OUTDOOR_OUTER_FENCE+  , cmaxStairsNum = 0+  , cdesc         = "Tired after the day's heat, the insects gather strength in their hiding places."+  }+flight = rogue  -- a scenario with weak missiles, because heroes don't depend+                -- on them; dark, so solid obstacles are to hide from missiles,+                -- not view; obstacles are not lit, to frustrate the AI;+                -- lots of small lights to cross, to have some risks+  { cname         = "Metropolitan park at dusk"  -- "night" didn't fit+  , cfreq         = [(CAVE_FLIGHT, 1)]+  , ccellSize     = DiceXY (1 `d` 3 + 7) 6+  , cminPlaceSize = DiceXY 5 3+  , cmaxPlaceSize = DiceXY 9 9  -- bias towards larger lamp areas+  , cdarkOdds     = 51  -- rooms always dark so that fence not visible from afar+  , cnightOdds    = 51  -- always night+  , cauxConnects  = 2  -- many lit trails, so easy to aim+  , cmaxVoid      = 1%100+  , chidden       = 0+  , cactorFreq    = []+  , citemNum      = 6 `d` 8+  , citemFreq     = [ (IK.COMMON_ITEM, 30), (GEM, 500)+                    , (WEAK_ARROW, 500), (HARPOON, 400)+                    , (IK.EXPLOSIVE, 100) ]+  , cplaceFreq    = [(FLIGHT, 1)]+  , cpassable     = True+  , cdefTile      = FLIGHT_SET_DARK  -- unlike in ambush, tiles not burning yet+  , cdarkCorTile  = SAFE_TRAIL_LIT  -- let trails give off light+  , clitCorTile   = SAFE_TRAIL_LIT+  , cfenceTileN   = OUTDOOR_OUTER_FENCE+  , cfenceTileE   = OUTDOOR_OUTER_FENCE+  , cfenceTileS   = OUTDOOR_OUTER_FENCE+  , cfenceTileW   = OUTDOOR_OUTER_FENCE+  , cmaxStairsNum = 0+  , cescapeFreq   = [(OUTDOOR_ESCAPE_DOWN, 1)]+  , cstairFreq    = []+  , cskip         = []+  , cdesc         = "The darkening greyness is settling into silence."+  }+zoo = rogue  -- few lights and many solids, to help the less numerous heroes+  { cname         = "Menagerie in flames"+  , cfreq         = [(CAVE_ZOO, 1)]+  , ccellSize     = DiceXY (1 `d` 3 + 7) 6+  , cminPlaceSize = DiceXY 4 4+  , cmaxPlaceSize = DiceXY 12 5+  , cdarkOdds     = 51  -- rooms always dark so that fence not visible from afar+  , cnightOdds    = 51  -- always night+  , cauxConnects  = 1%4+  , cmaxVoid      = 1%20+  , cdoorChance   = 7%10   , copenChance   = 9%10-  , chidden       = 1000+  , chidden       = 0   , cactorFreq    = []-  , citemNum      = 12 * d 2-  , citemFreq     = [("useful", 100)]-  , cplaceFreq    = [("ambush", 100)]+  , citemNum      = 7 `d` 8+  , citemFreq     = [ (IK.COMMON_ITEM, 100), (LIGHT_ATTENUATOR, 1000)+                    , (STARTING_WEAPON, 1000) ]+  , cplaceFreq    = [(ZOO, 1)]   , cpassable     = True-  , cdefTile      = "ambushSet"-  , cdarkCorTile  = "trailLit"  -- let trails give off light-  , clitCorTile   = "trailLit"+  , cdefTile      = ZOO_SET_DARK+  , cdarkCorTile  = SAFE_TRAIL_LIT  -- let trails give off light+  , clitCorTile   = SAFE_TRAIL_LIT+  , cstairFreq    = []+  , cfenceTileN   = OUTDOOR_OUTER_FENCE+  , cfenceTileE   = OUTDOOR_OUTER_FENCE+  , cfenceTileS   = OUTDOOR_OUTER_FENCE+  , cfenceTileW   = OUTDOOR_OUTER_FENCE+  , cmaxStairsNum = 0+  , cdesc         = "The night is filled with animal calls."   }-safari1 = ambush {cfreq = [("caveSafari1", 1)]}-safari2 = battle {cfreq = [("caveSafari2", 1)]}-safari3 = skirmish {cfreq = [("caveSafari3", 1)]}+ambush = rogue  -- a scenario with strong missiles;+                -- dark, so solid obstacles are to hide from missiles,+                -- not view, and they are all lit, because stopped missiles+                -- are frustrating, while a few LOS-only obstacles are not lit;+                -- few small lights to cross, giving a chance to snipe;+                -- crucial difference wrt shootout and hunt is that trajectories+                -- of missiles are usually not seen, so enemy can't be guessed;+                -- camping doesn't pay off, because enemies can sneak and only+                -- active scouting, throwing flares and shooting discovers them+  { cname         = "Burning metropolitan park"+  , cfreq         = [(CAVE_AMBUSH, 1)]+  , ccellSize     = DiceXY (1 `d` 4 + 7) 6+  , cminPlaceSize = DiceXY 5 3+  , cmaxPlaceSize = DiceXY 9 9  -- bias towards larger lamp areas+  , cdarkOdds     = 51  -- rooms always dark so that fence not visible from afar+  , cnightOdds    = 51  -- always night+  , cauxConnects  = 1%10  -- few lit trails, so hard to aim+  , chidden       = 0+  , cactorFreq    = []+  , citemNum      = 5 `d` 8+  , citemFreq     = [ (IK.COMMON_ITEM, 30)+                    , (ANY_ARROW, 400), (HARPOON, 300), (IK.EXPLOSIVE, 50) ]+  , cplaceFreq    = [(AMBUSH, 1)]+  , cpassable     = True+  , cdefTile      = AMBUSH_SET_DARK+  , cdarkCorTile  = TRAIL_LIT  -- let trails give off light+  , clitCorTile   = TRAIL_LIT+  , cstairFreq    = []+  , cfenceTileN   = OUTDOOR_OUTER_FENCE+  , cfenceTileE   = OUTDOOR_OUTER_FENCE+  , cfenceTileS   = OUTDOOR_OUTER_FENCE+  , cfenceTileW   = OUTDOOR_OUTER_FENCE+  , cmaxStairsNum = 0+  , cdesc         = "Fires have reached into the city, glowing in darkness."+  }++-- * Other caves; testing, Easter egg, future work++battle = rogue  -- few lights and many solids, to help the less numerous heroes+  { cname         = "Old battle ground"+  , cfreq         = [(CAVE_BATTLE, 1)]+  , ccellSize     = DiceXY (5 `d` 3 + 11) 5  -- cfenceApart results in 2 rows+  , cminPlaceSize = DiceXY 4 4+  , cmaxPlaceSize = DiceXY 9 7+  , cdarkOdds     = 0+  , cnightOdds    = 51  -- always night+  , cauxConnects  = 1%4+  , cmaxVoid      = 1%20+  , cdoorChance   = 2%10+  , copenChance   = 9%10+  , chidden       = 0+  , cactorFreq    = []+  , citemNum      = 5 `d` 8+  , citemFreq     = [(IK.COMMON_ITEM, 100), (LIGHT_ATTENUATOR, 200)]+  , cplaceFreq    = [(BATTLE, 50), (ROGUE, 50)]+  , cpassable     = True+  , cdefTile      = BATTLE_SET_DARK+  , cdarkCorTile  = SAFE_TRAIL_LIT  -- let trails give off light+  , clitCorTile   = SAFE_TRAIL_LIT+  , cfenceTileN   = OUTDOOR_OUTER_FENCE+  , cfenceTileE   = OUTDOOR_OUTER_FENCE+  , cfenceTileS   = OUTDOOR_OUTER_FENCE+  , cfenceTileW   = OUTDOOR_OUTER_FENCE+  , cfenceApart   = True  -- ensures no cut-off parts from collapsed+  , cmaxStairsNum = 0+  , cstairFreq    = []+  , cdesc         = "Eroded walls, rusted weapons and unidentifiable bones cruch underfoot all alike."+  }+safari1 = brawl+  { cname         = "Hunam habitat"+  , cfreq         = [(CAVE_SAFARI_1, 1)]+  , cminPlaceSize = DiceXY 5 3+  , cmaxStairsNum = 1+  , cstairFreq    = [ (OUTDOOR_WALLED_STAIRCASE, 20)+                    , (OUTDOOR_CLOSED_STAIRCASE, 80)+                    , (OUTDOOR_TINY_STAIRCASE, 1) ]+  , cskip         = [0]+  , cdesc         = "\"Act 1. Hunams scavenge in a forest in their usual disgusting way.\""+  }+safari2 = flight  -- lamps instead of trees, but ok, it's only a simulation+  { cname         = "Deep into the jungle"+  , cfreq         = [(CAVE_SAFARI_2, 1)]+  , cmaxStairsNum = 1+  , cescapeFreq   = []+  , cstairFreq    = [ (OUTDOOR_WALLED_STAIRCASE, 20)+                    , (OUTDOOR_CLOSED_STAIRCASE, 80)+                    , (OUTDOOR_TINY_STAIRCASE, 1) ]+  , cskip         = [0]+  , cdesc         = "\"Act 2. In the dark pure heart of the jungle noble animals roam freely.\""+  }+safari3 = zoo  -- glass rooms, but ok, it's only a simulation+  { cname         = "Jungle in flames"+  , cfreq         = [(CAVE_SAFARI_3, 1)]+  , cminPlaceSize = DiceXY 5 4+  , cescapeFreq   = [(OUTDOOR_ESCAPE_DOWN, 1)]+  , cmaxStairsNum = 1+  , cstairFreq    = [ (OUTDOOR_WALLED_STAIRCASE, 20)+                    , (OUTDOOR_CLOSED_STAIRCASE, 80)+                    , (OUTDOOR_TINY_STAIRCASE, 1) ]+  , cdesc         = "\"Act 3. Jealous hunams set jungle on fire and flee.\""+  }
GameDefinition/Content/FactionKind.hs view
@@ -1,73 +1,369 @@--- | The type of kinds of game factions (heroes, enemies, NPCs, etc.)--- for LambdaHack.-module Content.FactionKind ( cdefs ) where+-- | Definitions of kinds of factions present in a game, both human+-- and computer-controlled.+module Content.FactionKind+  ( -- * Group name patterns+    pattern EXPLORER_REPRESENTATIVE, pattern EXPLORER_SHORT, pattern EXPLORER_NO_ESCAPE, pattern EXPLORER_MEDIUM, pattern EXPLORER_TRAPPED, pattern EXPLORER_AUTOMATED, pattern EXPLORER_AUTOMATED_TRAPPED, pattern EXPLORER_CAPTIVE, pattern EXPLORER_PACIFIST, pattern COMPETITOR_REPRESENTATIVE, pattern COMPETITOR_SHORT, pattern COMPETITOR_NO_ESCAPE, pattern CIVILIAN_REPRESENTATIVE, pattern CONVICT_REPRESENTATIVE, pattern MONSTER_REPRESENTATIVE, pattern MONSTER_ANTI, pattern MONSTER_ANTI_CAPTIVE, pattern MONSTER_ANTI_PACIFIST, pattern MONSTER_TOURIST, pattern MONSTER_TOURIST_PASSIVE, pattern MONSTER_CAPTIVE, pattern MONSTER_CAPTIVE_NARRATING, pattern ANIMAL_REPRESENTATIVE, pattern ANIMAL_MAGNIFICENT, pattern ANIMAL_EXQUISITE, pattern ANIMAL_CAPTIVE, pattern ANIMAL_NARRATING, pattern ANIMAL_MAGNIFICENT_NARRATING, pattern ANIMAL_CAPTIVE_NARRATING, pattern HORROR_REPRESENTATIVE, pattern HORROR_CAPTIVE, pattern HORROR_PACIFIST+  , pattern REPRESENTATIVE+  , groupNamesSingleton, groupNames+  , -- * Content+    content+#ifdef EXPOSE_INTERNAL+  -- * Group name patterns+#endif+  ) where -import qualified Data.EnumMap.Strict as EM+import Prelude () -import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Core.Prelude -cdefs :: ContentDef FactionKind-cdefs = ContentDef-  { getSymbol = fsymbol-  , getName = fname-  , getFreq = ffreq-  , validate = validateFactionKind-  , content =-      [hero, civilian, monster, animal, horror]-  }-hero,        civilian, monster, animal, horror :: FactionKind+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Definition.Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.DefsInternal -hero = FactionKind-  { fsymbol       = '1'-  , fname         = "hero"-  , ffreq         = [("hero", 1)]-  , fSkillsLeader = allSkills-  , fSkillsOther  = meleeAdjacent-  }+import Content.ItemKindActor+import Content.ItemKindOrgan -civilian = FactionKind-  { fsymbol       = '@'-  , fname         = "civilian"-  , ffreq         = [("civilian", 1)]-  , fSkillsLeader = allSkills-  , fSkillsOther  = allSkills  -- not coordinated by any leadership+-- * Group name patterns++groupNamesSingleton :: [GroupName FactionKind]+groupNamesSingleton =+       [EXPLORER_REPRESENTATIVE, EXPLORER_SHORT, EXPLORER_NO_ESCAPE, EXPLORER_MEDIUM, EXPLORER_TRAPPED, EXPLORER_AUTOMATED, EXPLORER_AUTOMATED_TRAPPED, EXPLORER_CAPTIVE, EXPLORER_PACIFIST, COMPETITOR_REPRESENTATIVE, COMPETITOR_SHORT, COMPETITOR_NO_ESCAPE, CIVILIAN_REPRESENTATIVE, CONVICT_REPRESENTATIVE, MONSTER_REPRESENTATIVE, MONSTER_ANTI, MONSTER_ANTI_CAPTIVE, MONSTER_ANTI_PACIFIST, MONSTER_TOURIST, MONSTER_TOURIST_PASSIVE, MONSTER_CAPTIVE, MONSTER_CAPTIVE_NARRATING, ANIMAL_REPRESENTATIVE, ANIMAL_MAGNIFICENT, ANIMAL_EXQUISITE, ANIMAL_CAPTIVE, ANIMAL_NARRATING, ANIMAL_MAGNIFICENT_NARRATING, ANIMAL_CAPTIVE_NARRATING, HORROR_REPRESENTATIVE, HORROR_CAPTIVE, HORROR_PACIFIST]++pattern EXPLORER_REPRESENTATIVE, EXPLORER_SHORT, EXPLORER_NO_ESCAPE, EXPLORER_MEDIUM, EXPLORER_TRAPPED, EXPLORER_AUTOMATED, EXPLORER_AUTOMATED_TRAPPED, EXPLORER_CAPTIVE, EXPLORER_PACIFIST, COMPETITOR_REPRESENTATIVE, COMPETITOR_SHORT, COMPETITOR_NO_ESCAPE, CIVILIAN_REPRESENTATIVE, CONVICT_REPRESENTATIVE, MONSTER_REPRESENTATIVE, MONSTER_ANTI, MONSTER_ANTI_CAPTIVE, MONSTER_ANTI_PACIFIST, MONSTER_TOURIST, MONSTER_TOURIST_PASSIVE, MONSTER_CAPTIVE, MONSTER_CAPTIVE_NARRATING, ANIMAL_REPRESENTATIVE, ANIMAL_MAGNIFICENT, ANIMAL_EXQUISITE, ANIMAL_CAPTIVE, ANIMAL_NARRATING, ANIMAL_MAGNIFICENT_NARRATING, ANIMAL_CAPTIVE_NARRATING, HORROR_REPRESENTATIVE, HORROR_CAPTIVE, HORROR_PACIFIST :: GroupName FactionKind++groupNames :: [GroupName FactionKind]+groupNames = [REPRESENTATIVE]++pattern REPRESENTATIVE :: GroupName FactionKind++pattern REPRESENTATIVE = GroupName "representative"+pattern EXPLORER_REPRESENTATIVE = GroupName "explorer"+pattern EXPLORER_SHORT = GroupName "explorer short"+pattern EXPLORER_NO_ESCAPE = GroupName "explorer no escape"+pattern EXPLORER_MEDIUM = GroupName "explorer medium"+pattern EXPLORER_TRAPPED = GroupName "explorer trapped"+pattern EXPLORER_AUTOMATED = GroupName "explorer automated"+pattern EXPLORER_AUTOMATED_TRAPPED = GroupName "explorer automated trapped"+pattern EXPLORER_CAPTIVE = GroupName "explorer captive"+pattern EXPLORER_PACIFIST = GroupName "explorer pacifist"+pattern COMPETITOR_REPRESENTATIVE = GroupName "competitor"+pattern COMPETITOR_SHORT = GroupName "competitor short"+pattern COMPETITOR_NO_ESCAPE = GroupName "competitor no escape"+pattern CIVILIAN_REPRESENTATIVE = GroupName "civilian"+pattern CONVICT_REPRESENTATIVE = GroupName "convict"+pattern MONSTER_REPRESENTATIVE = GroupName "monster"+pattern MONSTER_ANTI = GroupName "monster anti"+pattern MONSTER_ANTI_CAPTIVE = GroupName "monster anti captive"+pattern MONSTER_ANTI_PACIFIST = GroupName "monster anti pacifist"+pattern MONSTER_TOURIST = GroupName "monster tourist"+pattern MONSTER_TOURIST_PASSIVE = GroupName "monster tourist passive"+pattern MONSTER_CAPTIVE = GroupName "monster captive"+pattern MONSTER_CAPTIVE_NARRATING = GroupName "monster captive narrating"+pattern ANIMAL_REPRESENTATIVE = GroupName "animal"+pattern ANIMAL_MAGNIFICENT = GroupName "animal magnificent"+pattern ANIMAL_EXQUISITE = GroupName "animal exquisite"+pattern ANIMAL_CAPTIVE = GroupName "animal captive"+pattern ANIMAL_NARRATING = GroupName "animal narrating"+pattern ANIMAL_MAGNIFICENT_NARRATING = GroupName "animal magnificent narrating"+pattern ANIMAL_CAPTIVE_NARRATING = GroupName "animal captive narrating"+pattern HORROR_REPRESENTATIVE = GroupName "horror"+pattern HORROR_CAPTIVE = GroupName "horror captive"+pattern HORROR_PACIFIST = GroupName "horror pacifist"++-- * Teams++teamCompetitor, teamCivilian, teamConvict, teamMonster, teamAnimal, teamHorror, teamOther :: TeamContinuity+teamCompetitor = TeamContinuity 2+teamCivilian = TeamContinuity 3+teamConvict = TeamContinuity 4+teamMonster = TeamContinuity 5+teamAnimal = TeamContinuity 6+teamHorror = TeamContinuity 7+teamOther = TeamContinuity 10++-- * Content++content :: [FactionKind]+content = [factExplorer, factExplorerShort, factExplorerNoEscape, factExplorerMedium, factExplorerTrapped, factExplorerAutomated, factExplorerAutomatedTrapped, factExplorerCaptive, factExplorerPacifist, factCompetitor, factCompetitorShort, factCompetitorNoEscape, factCivilian, factConvict, factMonster, factMonsterAnti, factMonsterAntiCaptive, factMonsterAntiPacifist, factMonsterTourist, factMonsterTouristPassive, factMonsterCaptive, factMonsterCaptiveNarrating, factAnimal, factAnimalMagnificent, factAnimalExquisite, factAnimalCaptive, factAnimalNarrating, factAnimalMagnificentNarrating, factAnimalCaptiveNarrating, factHorror, factHorrorCaptive, factHorrorPacifist]++factExplorer,            factExplorerShort, factExplorerNoEscape, factExplorerMedium, factExplorerTrapped, factExplorerAutomated, factExplorerAutomatedTrapped, factExplorerCaptive, factExplorerPacifist, factCompetitor, factCompetitorShort, factCompetitorNoEscape, factCivilian, factConvict, factMonster, factMonsterAnti, factMonsterAntiCaptive, factMonsterAntiPacifist, factMonsterTourist, factMonsterTouristPassive, factMonsterCaptive, factMonsterCaptiveNarrating, factAnimal, factAnimalMagnificent, factAnimalExquisite, factAnimalCaptive, factAnimalNarrating, factAnimalMagnificentNarrating, factAnimalCaptiveNarrating, factHorror, factHorrorCaptive, factHorrorPacifist :: FactionKind++-- * Content++-- ** teamExplorer++factExplorer = FactionKind+  { fname = "Explorer"+  , ffreq = [(EXPLORER_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)]+  , fteam = teamExplorer+  , fgroups = [(HERO, 100)]  -- don't spam the escapists, etc., in description+  , fskillsOther = meleeAdjacent+  , fcanEscape = True+  , fneverEmpty = True+  , fhiCondPoly = hiHeroLong+  , fhasGender = True+  , finitDoctrine = TExplore+  , fspawnsFast = False+  , fhasPointman = True+  , fhasUI = True+  , finitUnderAI = False+  , fenemyTeams = [teamCompetitor, teamMonster, teamAnimal, teamHorror]+  , falliedTeams = []   }+factExplorerShort = factExplorer+  { ffreq = [(EXPLORER_SHORT, 1)]+  , fhiCondPoly = hiHeroShort+  , fenemyTeams = [teamMonster, teamAnimal, teamHorror]+  }+factExplorerNoEscape = factExplorer+  { ffreq = [(EXPLORER_NO_ESCAPE, 1)]+  , fcanEscape = False+  , fhiCondPoly = hiHeroMedium+  }+factExplorerMedium = factExplorer+  { ffreq = [(EXPLORER_MEDIUM, 1)]+  , fhiCondPoly = hiHeroMedium+  }+factExplorerTrapped = factExplorer+  { ffreq = [(EXPLORER_TRAPPED, 1)]+  , fcanEscape = False+  , fhiCondPoly = hiHeroLong+  }+factExplorerAutomated = factExplorer+  { ffreq = [(EXPLORER_AUTOMATED, 1)]+  , fhasUI = False+  , finitUnderAI = True+  }+factExplorerAutomatedTrapped = factExplorerAutomated+  { ffreq = [(EXPLORER_AUTOMATED_TRAPPED, 1)]+  , fcanEscape = False+  , fhiCondPoly = hiHeroLong+  }+factExplorerCaptive = factExplorer+  { ffreq = [(EXPLORER_CAPTIVE, 1)]+  , fneverEmpty = True  -- already there+  }+factExplorerPacifist = factExplorerCaptive+  { ffreq = [(EXPLORER_PACIFIST, 1)]+  , fenemyTeams = []+  , falliedTeams = []+  } -monster = FactionKind-  { fsymbol       = 'm'-  , fname         = "monster"-  , ffreq         = [("monster", 1)]-  , fSkillsLeader = allSkills-  , fSkillsOther  = allSkills+-- ** teamCompetitor, symmetric opponents of teamExplorer++factCompetitor = factExplorer+  { fname = "Indigo Researcher"+  , ffreq = [(COMPETITOR_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)]+  , fteam = teamCompetitor+  , fhasUI = False+  , finitUnderAI = True+  , fenemyTeams = [teamExplorer, teamMonster, teamAnimal, teamHorror]+  , falliedTeams = []   }+factCompetitorShort = factCompetitor+  { fname = "Indigo Founder"  -- early+  , ffreq = [(COMPETITOR_SHORT, 1)]+  , fhiCondPoly = hiHeroShort+  , fenemyTeams = [teamMonster, teamAnimal, teamHorror]+  }+factCompetitorNoEscape = factCompetitor+  { ffreq = [(COMPETITOR_NO_ESCAPE, 1)]+  , fcanEscape = False+  , fhiCondPoly = hiHeroMedium+  } -animal = FactionKind-  { fsymbol       = 'd'-  , fname         = "animal"-  , ffreq         = [("animal", 1)]-  , fSkillsLeader = animalSkills-  , fSkillsOther  = animalSkills+-- ** teamCivilian++factCivilian = FactionKind+  { fname = "Civilian"+  , ffreq = [(CIVILIAN_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)]+  , fteam = teamCivilian+  , fgroups = [(HERO, 100), (CIVILIAN, 100)]  -- symmetric vs player+  , fskillsOther = zeroSkills  -- not coordinated by any leadership+  , fcanEscape = False+  , fneverEmpty = True+  , fhiCondPoly = hiHeroMedium+  , fhasGender = True+  , finitDoctrine = TPatrol+  , fspawnsFast = False+  , fhasPointman = False  -- unorganized+  , fhasUI = False+  , finitUnderAI = True+  , fenemyTeams = [teamMonster, teamAnimal, teamHorror]+  , falliedTeams = []   } -horror = FactionKind-  { fsymbol       = 'h'-  , fname         = "horror"-  , ffreq         = [("horror", 1)]-  , fSkillsLeader = allSkills-  , fSkillsOther  = allSkills+-- ** teamConvict, different demographics++factConvict = factCivilian+  { fname = "Hunam Convict"+  , ffreq = [(CONVICT_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)]+  , fteam = teamConvict+  , fhasPointman = True  -- convicts organize better+  , finitUnderAI = True+  , fenemyTeams = [teamMonster, teamAnimal, teamHorror]+  , falliedTeams = []   } +-- ** teamMonster -meleeAdjacent, _meleeAndRanged, animalSkills, allSkills :: Skills+factMonster = FactionKind+  { fname = "Monster Hive"+  , ffreq = [(MONSTER_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)]+  , fteam = teamMonster+  , fgroups = [ (MONSTER, 100)+              , (MOBILE_MONSTER, 1) ]+  , fskillsOther = zeroSkills+  , fcanEscape = False+  , fneverEmpty = False+  , fhiCondPoly = hiDweller+  , fhasGender = False+  , finitDoctrine = TExplore+  , fspawnsFast = True+  , fhasPointman = True+  , fhasUI = False+  , finitUnderAI = True+  , fenemyTeams = [teamExplorer, teamCompetitor, teamCivilian, teamConvict]+  , falliedTeams = [teamAnimal]+  }+-- This has continuity @teamMonster@, despite being playable.+factMonsterAnti = factMonster+  { ffreq = [(MONSTER_ANTI, 1)]+  , fhasUI = True+  , finitUnderAI = False+  }+factMonsterAntiCaptive = factMonsterAnti+  { ffreq = [(MONSTER_ANTI_CAPTIVE, 1)]+  , fneverEmpty = True+  }+factMonsterAntiPacifist = factMonsterAntiCaptive+  { ffreq = [(MONSTER_ANTI_PACIFIST, 1)]+  , fenemyTeams = []+  , falliedTeams = []+  }+-- More flavour and special backstory, but the same team.+factMonsterTourist = factMonsterAnti+  { fname = "Monster Tourist Office"+  , ffreq = [(MONSTER_TOURIST, 1)]+  , fcanEscape = True+  , fneverEmpty = True  -- no spawning+  , fhiCondPoly = hiHeroMedium+  , finitDoctrine = TFollow  -- follow-the-guide, as tourists do+  , fspawnsFast = False  -- on a trip, so no spawning+  , finitUnderAI = False+  , fenemyTeams =+      [teamAnimal, teamExplorer, teamCompetitor, teamCivilian, teamConvict]+  , falliedTeams = []+  }+factMonsterTouristPassive = factMonsterTourist+  { ffreq = [(MONSTER_TOURIST_PASSIVE, 1)]+  , fhasUI = False+  , finitUnderAI = True+  }+factMonsterCaptive = factMonster+  { ffreq = [(MONSTER_CAPTIVE, 1)]+  , fneverEmpty = True+  }+factMonsterCaptiveNarrating = factMonsterAntiCaptive+  { ffreq = [(MONSTER_CAPTIVE_NARRATING, 1)]+  , fhasUI = True+  } -meleeAdjacent = EM.fromList $ zip [AbWait, AbMelee] [1, 1..]+-- ** teamAnimal --- Melee and reaction fire.-_meleeAndRanged = EM.fromList $ zip [AbWait, AbMelee, AbProject] [1, 1..]+factAnimal = FactionKind+  { fname = "Animal Kingdom"+  , ffreq = [(ANIMAL_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)]+  , fteam = teamAnimal+  , fgroups = [ (ANIMAL, 100), (INSECT, 100), (GEOPHENOMENON, 100)+                   -- only the distinct enough ones+              , (MOBILE_ANIMAL, 1), (IMMOBILE_ANIMAL, 1), (SCAVENGER, 1) ]+  , fskillsOther = zeroSkills+  , fcanEscape = False+  , fneverEmpty = False+  , fhiCondPoly = hiDweller+  , fhasGender = False+  , finitDoctrine = TRoam  -- can't pick up, so no point exploring+  , fspawnsFast = True+  , fhasPointman = False+  , fhasUI = False+  , finitUnderAI = True+  , fenemyTeams = [teamExplorer, teamCompetitor, teamCivilian, teamConvict]+  , falliedTeams = [teamMonster]+  }+-- These two differ from outside, but share information and boasting+-- about them tends to be general, too.+factAnimalMagnificent = factAnimal+  { fname = "Animal Magnificent Specimen Variety"+  , ffreq = [(ANIMAL_MAGNIFICENT, 1)]+  , fneverEmpty = True+  , fenemyTeams =+      [teamMonster, teamExplorer, teamCompetitor, teamCivilian, teamConvict]+  , falliedTeams = []+  }+factAnimalExquisite = factAnimal+  { fname = "Animal Exquisite Herds and Packs Galore"+  , ffreq = [(ANIMAL_EXQUISITE, 1)]+  , fteam = teamOther+      -- in the same mode as @factAnimalMagnificent@, so borrow+      -- identity from horrors to avoid a clash+  , fneverEmpty = True+  , fenemyTeams =+      [teamMonster, teamExplorer, teamCompetitor, teamCivilian, teamConvict]+  , falliedTeams = []+  }+factAnimalCaptive = factAnimal+  { ffreq = [(ANIMAL_CAPTIVE, 1)]+  , fneverEmpty = True+  }+factAnimalNarrating = factAnimal+  { ffreq = [(ANIMAL_NARRATING, 1)]+  , fhasUI = True+  }+factAnimalMagnificentNarrating = factAnimalMagnificent+  { ffreq = [(ANIMAL_MAGNIFICENT_NARRATING, 1)]+  , fhasPointman = True+  , fhasUI = True+  , finitUnderAI = False+  }+factAnimalCaptiveNarrating = factAnimalCaptive+  { ffreq = [(ANIMAL_CAPTIVE_NARRATING, 1)]+  , fhasUI = True+  } -animalSkills =-  EM.fromList $ zip [AbMove, AbMelee, AbAlter, AbWait, AbTrigger] [1, 1..]+-- ** teamHorror, not much of a continuity intended, but can't be ignored -allSkills = unitSkills+-- | A special faction, for summoned actors that don't belong to any+-- of the main factions of a given game. E.g., animals summoned during+-- a brawl game between two hero factions land in the horror faction.+-- In every game, either all factions for which summoning items exist+-- should be present or a horror faction should be added to host them.+factHorror = FactionKind+  { fname = "Horror Den"+  , ffreq = [(HORROR_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)]+  , fteam = teamHorror+  , fgroups = [(IK.HORROR, 100)]+  , fskillsOther = zeroSkills+  , fcanEscape = False+  , fneverEmpty = False+  , fhiCondPoly = []+  , fhasGender = False+  , finitDoctrine = TPatrol  -- disoriented+  , fspawnsFast = False+  , fhasPointman = False+  , fhasUI = False+  , finitUnderAI = True+  , fenemyTeams = [teamExplorer, teamCompetitor, teamCivilian, teamConvict]+  , falliedTeams = []+  }+factHorrorCaptive = factHorror+  { ffreq = [(HORROR_CAPTIVE, 1)]+  , fneverEmpty = True+  }+factHorrorPacifist = factHorrorCaptive+  { ffreq = [(HORROR_PACIFIST, 1)]+  , fenemyTeams = []+  , falliedTeams = []+  }
GameDefinition/Content/ItemKind.hs view
@@ -1,695 +1,1861 @@--- | Weapon and treasure definitions.-module Content.ItemKind ( cdefs ) where--import Data.List--import Content.ItemKindActor-import Content.ItemKindOrgan-import Content.ItemKindShrapnel-import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Dice-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.ItemKind--cdefs :: ContentDef ItemKind-cdefs = ContentDef-  { getSymbol = isymbol-  , getName = iname-  , getFreq = ifreq-  , validate = validateItemKind-  , content = items ++ organs ++ shrapnels ++ actors-  }--items :: [ItemKind]-items =-  [bolas, brassLantern, buckler, dart, dart200, gem1, gem2, gem3, gloveFencing, gloveGauntlet, gloveJousting, currency, gorget, harpoon, jumpingPole, monocle, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, net, oilLamp, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, ring1, ring2, ring3, ring4, ring5, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, shield, dagger, hammer, sword, halberd, wand1, wand2, woodenTorch, armorLeather, armorMail, whetstone]--bolas,    brassLantern, buckler, dart, dart200, gem1, gem2, gem3, gloveFencing, gloveGauntlet, gloveJousting, currency, gorget, harpoon, jumpingPole, monocle, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, net, oilLamp, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, ring1, ring2, ring3, ring4, ring5, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, shield, dagger, hammer, sword, halberd, wand1, wand2, woodenTorch, armorLeather, armorMail, whetstone :: ItemKind--gem, necklace, potion, ring, scroll, wand :: ItemKind  -- generic templates---- * Thrown weapons--dart = ItemKind-  { isymbol  = '|'-  , iname    = "dart"-  , ifreq    = [("useful", 100), ("any arrow", 100)]-  , iflavour = zipPlain [Cyan]-  , icount   = 3 * d 3-  , irarity  = [(1, 20)]-  , iverbHit = "prick"-  , iweight  = 50-  , iaspects = [AddHurtRanged ((d 6 + dl 6) |*| 10)]-  , ieffects = [Hurt (3 * d 1)]-  , ifeature = []-  , idesc    = "Little, but sharp and sturdy."  -- "Much inferior to arrows though, especially given the contravariance problems."  --- funny, but destroy the suspension of disbelief; this is supposed to be a Lovecraftian horror and any hilarity must ensue from the failures in making it so and not from actively trying to be funny; also, mundane objects are not supposed to be scary or transcendental; the scare is in horrors from the abstract dimension visiting our ordinary reality; without the contrast there's no horror and no wonder, so also the magical items must be contrasted with ordinary XIX century and antique items-  , ikit     = []-  }-dart200 = ItemKind-  { isymbol  = '|'-  , iname    = "fine dart"-  , ifreq    = [("useful", 100), ("any arrow", 50)]  -- TODO: until arrows added-  , iflavour = zipPlain [BrRed]-  , icount   = 3 * d 3-  , irarity  = [(4, 20)]-  , iverbHit = "prick"-  , iweight  = 50-  , iaspects = [AddHurtRanged ((d 6 + dl 6) |*| 10)]-  , ieffects = [Hurt (2 * d 1)]-  , ifeature = [toVelocity 200]-  , idesc    = "Finely balanced for throws of great speed."-  , ikit     = []-  }---- * Exotic thrown weapons--bolas = ItemKind-  { isymbol  = '|'-  , iname    = "bolas set"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = dl 4-  , irarity  = [(5, 5), (10, 5)]-  , iverbHit = "entangle"-  , iweight  = 500-  , iaspects = []-  , ieffects = [Hurt (2 * d 1), Paralyze (5 + d 5), ActivateInv '!']-  , ifeature = []-  , idesc    = "Wood balls tied with hemp rope for tripping, entangling and bringing down crashing."-  , ikit     = []-  }-harpoon = ItemKind-  { isymbol  = '|'-  , iname    = "harpoon"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Brown]-  , icount   = dl 5-  , irarity  = [(5, 5), (10, 20)]-  , iverbHit = "hook"-  , iweight  = 4000-  , iaspects = [AddHurtRanged ((d 2 + 2 * dl 5) |*| 10)]-  , ieffects = [Hurt (4 * d 1), PullActor (ThrowMod 200 50)]-  , ifeature = []-  , idesc    = "The cruel, barbed head lodges in its victim so painfully that the weakest tug of the thin line sends the victim flying."-  , ikit     = []-  }-net = ItemKind-  { isymbol  = '|'-  , iname    = "net"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [White]-  , icount   = dl 3-  , irarity  = [(3, 5), (10, 4)]-  , iverbHit = "entangle"-  , iweight  = 1000-  , iaspects = []-  , ieffects = [ Paralyze (5 + d 5)-               , DropBestWeapon, DropEqp ']' False ]-  , ifeature = []-  , idesc    = "A wide net with weights along the edges. Entangles weapon and armor alike."-  , ikit     = []-  }---- * Lights--woodenTorch = ItemKind-  { isymbol  = '('-  , iname    = "wooden torch"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Brown]-  , icount   = 1-  , irarity  = [(1, 10)]-  , iverbHit = "scorch"-  , iweight  = 1200-  , iaspects = [ AddLight 3-               , AddSight (-2) ]  -- not only flashes, but also sparks-  , ieffects = [Burn 3]-  , ifeature = [EqpSlot EqpSlotAddLight "", Identified]-  , idesc    = "A smoking, heavy wooden torch, burning in an unsteady fire."-  , ikit     = []-  }-oilLamp = ItemKind-  { isymbol  = '('-  , iname    = "oil lamp"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 1-  , irarity  = [(5, 4), (10, 4)]-  , iverbHit = "burn"-  , iweight  = 1000-  , iaspects = [AddLight 3, AddSight (-1)]-  , ieffects = [Burn 3, Paralyze 3, OnSmash (Explode "burning oil 3")]-  , ifeature = [ toVelocity 70  -- hard not to spill the oil while throwing-               , Fragile, EqpSlot EqpSlotAddLight "", Identified ]-  , idesc    = "A clay lamp filled with plant oil feeding a tiny wick."-  , ikit     = []-  }-brassLantern = ItemKind-  { isymbol  = '('-  , iname    = "brass lantern"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrWhite]-  , icount   = 1-  , irarity  = [(10, 3)]-  , iverbHit = "burn"-  , iweight  = 2400-  , iaspects = [AddLight 4, AddSight (-1)]-  , ieffects = [Burn 4, Paralyze 4, OnSmash (Explode "burning oil 4")]-  , ifeature = [ toVelocity 70  -- hard to throw so that it opens and burns-               , Fragile, EqpSlot EqpSlotAddLight "", Identified ]-  , idesc    = "Very bright and very heavy brass lantern."-  , ikit     = []-  }---- * Treasure--gem = ItemKind-  { isymbol  = '*'-  , iname    = "gem"-  , ifreq    = [("treasure", 100)]  -- x3, but rare on shallow levels-  , iflavour = zipPlain $ delete BrYellow brightCol  -- natural, so not fancy-  , icount   = 1-  , irarity  = []-  , iverbHit = "tap"-  , iweight  = 50-  , iaspects = [AddLight 1, AddSpeed (-1)]  -- reflects strongly, distracts-  , ieffects = []-  , ifeature = [ Durable  -- prevent destruction by evil monsters-               , Precious ]-  , idesc    = "Useless, and still worth around 100 gold each. Would gems of thought and pearls of artful design be valued that much in our age of Science and Progress!"-  , ikit     = []-  }-gem1 = gem-  { irarity  = [(2, 0), (10, 10)]-  }-gem2 = gem-  { irarity  = [(5, 0), (10, 10)]-  }-gem3 = gem-  { irarity  = [(8, 0), (10, 10)]-  }-currency = ItemKind-  { isymbol  = '$'-  , iname    = "gold piece"-  , ifreq    = [("treasure", 100), ("currency", 1)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 10 + d 20 + dl 20-  , irarity  = [(1, 0), (5, 20), (10, 10)]-  , iverbHit = "tap"-  , iweight  = 31-  , iaspects = []-  , ieffects = []-  , ifeature = [Durable, Identified, Precious]-  , idesc    = "Reliably valuable in every civilized plane of existence."-  , ikit     = []-  }---- * Periodic jewelry--gorget = ItemKind-  { isymbol  = '"'-  , iname    = "gorget"-  , ifreq    = [("useful", 100)]-  , iflavour = zipFancy [BrCyan]-  , irarity  = [(4, 1), (10, 2)]-  , icount   = 1-  , iverbHit = "whip"-  , iweight  = 30-  , iaspects = [Periodic $ d 4 + dl 4, AddArmorMelee 1, AddArmorRanged 1]-  , ieffects = [RefillCalm 1]-  , ifeature = [ Precious, EqpSlot EqpSlotPeriodic "", Identified-               , toVelocity 50 ]  -- not dense enough-  , idesc    = "Highly ornamental, cold, large, steel medallion on a chain. Unlikely to offer much protection as an armor piece, but the old, worn engraving reassures you."-  , ikit     = []-  }-necklace = ItemKind-  { isymbol  = '"'-  , iname    = "necklace"-  , ifreq    = [("useful", 100)]-  , iflavour = zipFancy stdCol ++ zipPlain brightCol-  , irarity  = [(4, 2), (10, 5)]-  , icount   = 1-  , iverbHit = "whip"-  , iweight  = 30-  , iaspects = []-  , ieffects = []-  , ifeature = [ Precious, EqpSlot EqpSlotPeriodic ""-               , toVelocity 50 ]  -- not dense enough-  , idesc    = "Menacing Greek symbols shimmer with increasing speeds along a chain of fine encrusted links. After a tense build-up, a prismatic arc shoots towards the ground and the iridescence subdues, becomes ordered and resembles a harmless ornament again, for a time."-  , ikit     = []-  }-necklace1 = necklace-  { iaspects = [Periodic $ d 2 + dl 2]-  , ieffects = [RefillHP 1]-  , idesc    = "A cord of dried herbs and healing berries."-  }-necklace2 = necklace-  { irarity  = [(2, 0), (10, 1)]-  , iaspects = [Periodic $ d 4 + dl 2]-  , ieffects = [ Impress-               , Summon [("summonable animal", 1)] $ 1 + dl 2, Explode "waste" ]-  }-necklace3 = necklace-  { iaspects = [Periodic $ d 4 + dl 2]-  , ieffects = [Paralyze $ 5 + d 5 + dl 5, RefillCalm 999]-  }-necklace4 = necklace-  { iaspects = [Periodic $ 2 * d 10 + dl 10]-  , ieffects = [Teleport $ 2 + d 3]-  }-necklace5 = necklace-  { iaspects = [Periodic $ d 4 + dl 2]-  , ieffects = [Teleport $ 10 + d 10]-  }-necklace6 = necklace-  { iaspects = [Periodic $ 2 * d 5 + dl 5]-  , ieffects = [PushActor (ThrowMod 100 50)]-  }-necklace7 = necklace-  { irarity  = [(4, 0), (10, 2)]-  , iaspects = [Periodic $ 2 * d 5 + dl 15]-  , ieffects = [InsertMove 1, RefillHP (-1)]-  , ifeature = ifeature necklace ++ [Durable]-      -- evil players would throw before death, to destroy-      -- TODO: teach AI to wear only for fight; prevent players from meleeing-      -- allies with that (Durable)-  }---- * Non-periodic jewelry--monocle = ItemKind-  { isymbol  = '='-  , iname    = "monocle"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [White]-  , icount   = 1-  , irarity  = [(6, 0), (10, 1)]-  , iverbHit = "rap"-  , iweight  = 50-  , iaspects = [AddSight $ dl 3]-  , ieffects = []-  , ifeature = [Precious, Identified, Durable, EqpSlot EqpSlotAddSight ""]-  , idesc    = "Let's you better focus your weaker eye."-  , ikit     = []-  }-ring = ItemKind-  { isymbol  = '='-  , iname    = "ring"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain stdCol ++ zipFancy darkCol-  , icount   = 1-  , irarity  = [(6, 2), (10, 5)]-  , iverbHit = "knock"-  , iweight  = 15-  , iaspects = []-  , ieffects = []-  , ifeature = [Precious, Identified]-  , idesc    = "It looks like an ordinary object, but it's in fact a generator of exceptional effects: adding to some of your natural abilities and subtracting from others. You'd profit enormously if you could find a way to multiply such generators..."  -- TODO: merge rings: do not add effects though, because it would make the ring too powerful (only one eqp slot taken); define correct, but not overpowered multiplication, if possible-  , ikit     = []-  }-ring1 = ring-  { irarity  = [(2, 0), (10, 2)]-  , iaspects = [AddSpeed 1, AddMaxHP $ dl 3 - 5 - d 3]-  , ifeature = ifeature ring ++ [Durable, EqpSlot EqpSlotAddSpeed ""]-  }-ring2 = ring-  { iaspects = [AddMaxHP $ 3 + dl 5, AddMaxCalm $ dl 6 - 15 - d 6]-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxHP ""]-  }-ring3 = ring-  { iaspects = [AddMaxCalm $ 10 + dl 10]-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxCalm ""]-  , idesc    = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words."-  }-ring4 = ring  -- TODO: move to level-ups and to timed effects-  { irarity  = [(3, 8), (10, 12)]-  , iaspects = [AddHurtMelee $ 3 * d 4 + dl 15, AddMaxHP $ dl 3 - 4 - d 2]-  , ifeature = ifeature ring ++ [Durable, EqpSlot EqpSlotAddHurtMelee ""]-  }-ring5 = ring  -- by the time it's found, probably no space in eqp-  { irarity  = [(5, 0), (10, 1)]-  , iaspects = [AddLight $ d 2]-  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddLight ""]-  , idesc    = "A sturdy ring with a large, shining stone."-  }---- * Exploding consumables, often intended to be thrown--potion = ItemKind-  { isymbol  = '!'-  , iname    = "potion"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain stdCol ++ zipFancy brightCol-  , icount   = 1-  , irarity  = [(1, 10), (10, 8)]-  , iverbHit = "splash"-  , iweight  = 200-  , iaspects = []-  , ieffects = []-  , ifeature = [ toVelocity 50  -- oily, bad grip-               , Applicable, Fragile ]-  , idesc    = "A flask of bubbly, slightly oily liquid of a suspect color."  -- purely natural; no maths, no magic  -- TODO: move distortion to a special flask item or when some precious magical item is destroyed (jewelry?)?-  , ikit     = []-  }-potion1 = potion-  { ieffects = [ NoEffect "of rose water", Impress-               , OnSmash (ApplyPerfume), OnSmash (Explode "fragrance") ]-  }-potion2 = potion-  { ifreq    = [("useful", 1)]  -- extremely rare-  , irarity  = [(10, 1)]-  , ieffects = [ NoEffect "of musky concoction", Impress, DropBestWeapon-               , OnSmash (Explode "pheromone")]-  }-potion3 = potion-  { ieffects = [RefillHP 5, OnSmash (Explode "healing mist")]-  }-potion4 = potion  -- TODO: a bit boring-  { irarity  = [(1, 5)]-  , ieffects = [RefillHP (-5), OnSmash (Explode "wounding mist")]-  }-potion5 = potion-  { ieffects = [ Explode "explosion blast 10", Impress-               , PushActor (ThrowMod 200 75)-               , OnSmash (Explode "explosion blast 10") ]-  }-potion6 = potion-  { irarity  = [(10, 2)]-  , ieffects = [ NoEffect "of distortion"-               , OnSmash (Explode "distortion")]-  }-potion7 = potion-  { ieffects = [ NoEffect "of bait cocktail", Impress-               , OnSmash (Summon [("summonable animal", 1)] $ 1 + dl 2)-               , OnSmash (Explode "waste") ]-  }-potion8 = potion-  { ieffects = [ OneOf [Impress, DropBestWeapon, RefillHP 5, Burn 3]-               , OnSmash (OneOf [ Explode "healing mist"-                                , Explode "wounding mist"-                                , Explode "fragrance"-                                , Explode "explosion blast 10" ]) ]-  }-potion9 = potion-  { irarity  = [(4, 1), (10, 2)]-  , ieffects = [ OneOf [ Dominate, DropBestWeapon, RefillHP 15, Burn 9-                       , InsertMove 2]-               , OnSmash (OneOf [ Explode "healing mist"-                                , Explode "healing mist"-                                , Explode "pheromone"-                                , Explode "distortion"-                                , Explode "explosion blast 20" ]) ]-  }-potion10 = potion-  { ifreq    = [("useful", 100), ("potion of glue", 1)]-  , irarity  = [(1, 1)]-  , icount   = 1 + d 2-  , ieffects = [ NoEffect "of glue", Paralyze (5 + d 5)-               , OnSmash (Explode "glue")]-  }---- * Non-exploding consumables, not specifically designed for throwing--scroll = ItemKind-  { isymbol  = '?'-  , iname    = "scroll"-  , ifreq    = [("useful", 100), ("any scroll", 100)]-  , iflavour = zipFancy stdCol ++ zipPlain darkCol  -- arcane and old-  , icount   = 1-  , irarity  = [(1, 10), (10, 7)]-  , iverbHit = "thump"-  , iweight  = 50-  , iaspects = []-  , ieffects = []-  , ifeature = [ toVelocity 25  -- bad shape, even rolled up-               , Applicable ]-  , idesc    = "Scraps of haphazardly scribbled mysteries from beyond. Is this equation an alchemical recipe? Is this diagram an extradimensional map? Is this formula a secret call sign?"-  , ikit     = []-  }-scroll1 = scroll-  { irarity  = [(10, 2)]-  , ieffects = [CallFriend 1]-  }-scroll2 = scroll-  { irarity  = [(1, 5), (10, 3)]-  , ieffects = [NoEffect "of fireworks", Explode "firecracker 7"]-  }-scroll3 = scroll-  { irarity  = [(1, 4), (10, 2)]-  , ieffects = [Ascend (-1)]-  }-scroll4 = scroll-  { ieffects = [ OneOf [ Teleport $ 2 + d 5, RefillCalm 10, RefillCalm (-10)-                       , InsertMove 4, Paralyze 10, Identify CGround ] ]-  }-scroll5 = scroll-  { irarity  = [(1, 4), (10, 6)]-  , ieffects = [ OneOf [ Summon standardSummon $ d 2-                       , CallFriend 1, Ascend (-1), Ascend 1-                       , RefillCalm 30, RefillCalm (-30), CreateItem $ d 2-                       , PolyItem CGround ] ]-               -- TODO: ask player: Escape 1-  }-scroll6 = scroll-  { ieffects = [Teleport $ 2 + d 5]-  }-scroll7 = scroll-  { irarity  = [(10, 2)]-  , ieffects = [InsertMove $ d 2 + dl 2]-  }-scroll8 = scroll-  { irarity  = [(3, 6), (10, 3)]-  , ieffects = [Identify CGround]  -- TODO: ask player: AskPlayer cstore eff?-  }-scroll9 = scroll-  { irarity  = [(3, 3), (10, 9)]-  , ieffects = [PolyItem CGround]-  }--standardSummon :: Freqs-standardSummon = [("monster", 30), ("summonable animal", 70)]---- * Armor--armorLeather = ItemKind-  { isymbol  = '['-  , iname    = "leather armor"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Brown]-  , icount   = 1-  , irarity  = [(4, 9)]-  , iverbHit = "thud"-  , iweight  = 7000-  , iaspects = [ AddHurtMelee (-3)-               , AddArmorMelee $ (1 + dl 3) |*| 5-               , AddArmorRanged $ (1 + dl 3) |*| 5 ]-  , ieffects = []-  , ifeature = [ toVelocity 30  -- unwieldy to throw and blunt-               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]-  , idesc    = "A stiff jacket formed from leather boiled in bee wax. Smells much better than the rest of your garment."-  , ikit     = []-  }-armorMail = armorLeather-  { iname    = "mail armor"-  , iflavour = zipPlain [Cyan]-  , irarity  = [(7, 9)]-  , iweight  = 12000-  , iaspects = [ AddHurtMelee (-3)-               , AddArmorMelee $ (2 + dl 3) |*| 5-               , AddArmorRanged $ (2 + dl 3) |*| 5 ]-  , idesc    = "A long shirt woven from iron rings. Discourages foes from attacking your torso, making it harder for them to land a blow."-  }-gloveFencing = ItemKind-  { isymbol  = '['-  , iname    = "leather gauntlet"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 1-  , irarity  = [(4, 6), (10, 12)]-  , iverbHit = "flap"-  , iweight  = 100-  , iaspects = [ AddHurtMelee $ 2 * (d 3 + 2 * dl 5)-               , AddArmorRanged $ d 2 + dl 2 ]-  , ieffects = []-  , ifeature = [ toVelocity 30  -- flaps and flutters-               , Durable, EqpSlot EqpSlotAddArmorRanged "", Identified ]-  , idesc    = "A fencing glove from rough leather ensuring a good grip. Also quite effective in deflecting or even catching slow projectiles."-  , ikit     = []-  }-gloveGauntlet = gloveFencing-  { iname    = "steel gauntlet"-  , irarity  = [(6, 12)]-  , iflavour = zipPlain [BrCyan]-  , iweight  = 300-  , iaspects = [ AddArmorMelee $ 2 * (d 2 + dl 2)-               , AddArmorRanged $ 2 * (d 2 + dl 2) ]-  , idesc    = "Long leather gauntlet covered in overlapping steel plates."-  }-gloveJousting = gloveFencing-  { iname    = "jousting gauntlet"-  , irarity  = [(6, 6)]-  , iflavour = zipFancy [BrRed]-  , iweight  = 500-  , iaspects = [ AddHurtMelee $ - 10 - d 5 + dl 5-               , AddArmorMelee $ 2 * (d 2 + dl 3)-               , AddArmorRanged $ 2 * (d 2 + dl 3) ]-  , idesc    = "Rigid, steel, jousting handgear. If only you had a lance. And a horse."-  }--- Shield doesn't protect against ranged attacks to prevent--- micromanagement: walking with shield, melee without.-buckler = ItemKind-  { isymbol  = '['-  , iname    = "buckler"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Blue]-  , icount   = 1-  , irarity  = [(4, 7)]-  , iverbHit = "bash"-  , iweight  = 2000-  , iaspects = [AddArmorMelee 40, AddHurtMelee (-30)]-  , ieffects = []-  , ifeature = [ toVelocity 30  -- unwieldy to throw and blunt-               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]-  , idesc    = "Heavy and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too small to intercept projectiles with."-  , ikit     = []-  }-shield = buckler-  { iname    = "shield"-  , irarity  = [(7, 7)]-  , iflavour = zipPlain [Green]-  , iweight  = 3000-  , iaspects = [AddArmorMelee 80, AddHurtMelee (-70)]-  , ifeature = [ toVelocity 20  -- unwieldy to throw and blunt-               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]-  , idesc    = "Large and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too heavy to intercept projectiles with."-  }---- * Weapons--dagger = ItemKind-  { isymbol  = ')'-  , iname    = "dagger"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrCyan]-  , icount   = 1-  , irarity  = [(1, 20), (10, 4)]-  , iverbHit = "stab"-  , iweight  = 1000-  , iaspects = [AddHurtMelee $ 2 * (d 3 + 2 * dl 5), AddArmorMelee $ d 4 + dl 4]-  , ieffects = [Hurt (4 * d 1)]-  , ifeature = [ toVelocity 40  -- ensuring it hits with the tip costs speed-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "A short dagger for thrusting and parrying blows. Does not penetrate deeply, but is hard to block. Especially useful in conjunction with a larger weapon."-  , ikit     = []-  }-hammer = ItemKind-  { isymbol  = ')'-  , iname    = "war hammer"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrMagenta]-  , icount   = 1-  , irarity  = [(4, 12), (10, 2)]-  , iverbHit = "club"-  , iweight  = 1500-  , iaspects = [AddHurtMelee $ d 3 + 2 * dl 5]-  , ieffects = [Hurt (6 * d 1)]-  , ifeature = [ toVelocity 20  -- ensuring it hits with the sharp tip costs-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "It may not cause grave wounds, but neither does it glance off nor ricochet. Great sidearm for opportunistic blows against armored foes."-  , ikit     = []-  }-sword = ItemKind-  { isymbol  = ')'-  , iname    = "sword"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrBlue]-  , icount   = 1-  , irarity  = [(3, 1), (6, 20), (10, 10)]-  , iverbHit = "slash"-  , iweight  = 2000-  , iaspects = []-  , ieffects = [Hurt (9 * d 1)]-  , ifeature = [ toVelocity 20  -- ensuring it hits with the tip costs speed-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "Difficult to master; deadly when used effectively. The steel is particularly hard and keen, but rusts quickly without regular maintenance."-  , ikit     = []-  }-halberd = ItemKind-  { isymbol  = ')'-  , iname    = "halberd"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 1-  , irarity  = [(7, 1), (10, 10)]-  , iverbHit = "impale"-  , iweight  = 3000-  , iaspects = [AddArmorMelee $ 2 * (d 4 + dl 4)]-  , ieffects = [Hurt (12 * d 1)]-  , ifeature = [ toVelocity 20  -- not balanced-               , Durable, EqpSlot EqpSlotWeapon "", Identified ]-  , idesc    = "Versatile, with great reach and leverage. Foes are held at a distance."-  , ikit     = []-  }---- * Wands--wand = ItemKind-  { isymbol  = '/'-  , iname    = "wand"-  , ifreq    = [("useful", 100)]-  , iflavour = zipFancy brightCol-  , icount   = 1-  , irarity  = []  -- TODO: add charges, etc.-  , iverbHit = "club"-  , iweight  = 300-  , iaspects = [AddLight 1, AddSpeed (-1)]  -- pulsing with power, distracts-  , ieffects = []-  , ifeature = [ toVelocity 125  -- magic-               , Applicable, Durable ]-  , idesc    = "Buzzing with dazzling light that shines even through appendages that handle it."  -- TODO: add math flavour-  , ikit     = []-  }-wand1 = wand-  { ieffects = []  -- TODO: emit a cone of sound shrapnel that makes enemy cover his ears and so drop '|' and '{'-  }-wand2 = wand-  { ieffects = []-  }---- * Assorted tools--jumpingPole = ItemKind-  { isymbol  = '('-  , iname    = "jumping pole"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [White]-  , icount   = 1-  , irarity  = [(1, 4), (10, 2)]-  , iverbHit = "prod"-  , iweight  = 10000-  , iaspects = []-  , ieffects = [InsertMove 2]  -- TODO: implement with timed speed instead-                               -- and then make Durable, freq 2, and just trade-                               -- taken turn now for a free turn later-  , ifeature = [Applicable, Identified]-  , idesc    = "Makes you vulnerable at take-off, but then you are free like a bird."-  , ikit     = []-  }-whetstone = ItemKind-  { isymbol  = '~'-  , iname    = "whetstone"-  , ifreq    = [("useful", 100)]-  , iflavour = zipPlain [Blue]-  , icount   = 1-  , irarity  = [(5, 5)]-  , iverbHit = "smack"-  , iweight  = 400-  , iaspects = [AddHurtMelee $ 2 * (d 3 + 2 * dl 5)]-  , ieffects = []-  , ifeature = [EqpSlot EqpSlotAddHurtMelee "", Identified]-  , idesc    = "A portable sharpening stone that lets you fix your weapons between or even during fights, without the need to set up camp, fish out tools and assemble a proper sharpening workshop."+-- | Definitions of basic items.+module Content.ItemKind+  ( -- * Group name patterns+    pattern HARPOON, pattern EDIBLE_PLANT, pattern RING_OF_OPPORTUNITY_GRENADIER, pattern ARMOR_LOOSE, pattern CLOTHING_MISC, pattern CHIC_GEAR+  , groupNamesSingleton, groupNames+  , -- * Content+    content, items, otherItemContent+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Core.Dice+import Game.LambdaHack.Definition.Ability+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal+import Game.LambdaHack.Definition.Flavour++import Content.ItemKindActor+import Content.ItemKindBlast+import Content.ItemKindEmbed+import Content.ItemKindOrgan+import Content.ItemKindTemporary+import Content.RuleKind++-- * Group name patterns++groupNamesSingleton :: [GroupName ItemKind]+groupNamesSingleton =+       [S_FRAGRANCE, S_SINGLE_SPARK, S_SPARK]+    ++ [FLASK_UNKNOWN, POTION_UNKNOWN, EDIBLE_PLANT_UNKNOWN, SCROLL_UNKNOWN, NECKLACE_UNKNOWN, RING_UNKNOWN, HAMMER_UNKNOWN, GEM_UNKNOWN, CURRENCY_UNKNOWN]+    ++ actorsGNSingleton ++ organsGNSingleton+    ++ blastsGNSingleton ++ temporariesGNSingleton++pattern FLASK_UNKNOWN, POTION_UNKNOWN, EDIBLE_PLANT_UNKNOWN, SCROLL_UNKNOWN, NECKLACE_UNKNOWN, RING_UNKNOWN, HAMMER_UNKNOWN, GEM_UNKNOWN, CURRENCY_UNKNOWN :: GroupName ItemKind++groupNames :: [GroupName ItemKind]+groupNames =+       [TREASURE, ANY_SCROLL, ANY_GLASS, ANY_POTION, ANY_FLASK, EXPLOSIVE, ANY_JEWELRY, VALUABLE, UNREPORTED_INVENTORY]+    ++ [HARPOON, EDIBLE_PLANT, RING_OF_OPPORTUNITY_GRENADIER, ARMOR_LOOSE, CLOTHING_MISC, CHIC_GEAR]+    ++ embedsGN ++ actorsGN ++ organsGN ++ blastsGN++pattern HARPOON, EDIBLE_PLANT, RING_OF_OPPORTUNITY_GRENADIER, ARMOR_LOOSE, CLOTHING_MISC, CHIC_GEAR :: GroupName ItemKind++-- The @UNKNOWN@ patterns don't need to be exported. Used internally.+-- They also represent singleton groups.+pattern FLASK_UNKNOWN = GroupName "flask unknown"+pattern POTION_UNKNOWN = GroupName "potion unknown"+pattern EDIBLE_PLANT_UNKNOWN = GroupName "edible plant unknown"+pattern SCROLL_UNKNOWN = GroupName "scroll unknown"+pattern NECKLACE_UNKNOWN = GroupName "necklace unknown"+pattern RING_UNKNOWN = GroupName "ring unknown"+pattern HAMMER_UNKNOWN = GroupName "hammer unknown"+pattern GEM_UNKNOWN = GroupName "gem unknown"+pattern CURRENCY_UNKNOWN = GroupName "currency unknown"++pattern HARPOON = GroupName "harpoon"+pattern EDIBLE_PLANT = GroupName "edible plant"+pattern RING_OF_OPPORTUNITY_GRENADIER = GroupName "ring of grenadier"+pattern ARMOR_LOOSE = GroupName "loose armor"+pattern CLOTHING_MISC = GroupName "miscellaneous clothing"+pattern CHIC_GEAR = GroupName "chic gear"++-- * Content++content :: [ItemKind]+content = items ++ otherItemContent++otherItemContent :: [ItemKind]+otherItemContent = embeds ++ actors ++ organs ++ blasts ++ temporaries++items :: [ItemKind]+items =+  [sandstoneRock, dart, spike, spike2, slingStone, slingBullet, paralizingProj, harpoon, harpoon2, net, fragmentationBomb, concussionBomb, flashBomb, firecrackerBomb, flaskTemplate, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, flask15, potionTemplate, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, potion11, potion12, potion13, potion14, potion15, scrollTemplate, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, scroll12, scroll13, ediblePlantTemplate, ediblePlant1, ediblePlant2, ediblePlant3, ediblePlant4, ediblePlant5, ediblePlant6, ediblePlant7, light1, light2, light3, blanket, gorget, necklaceTemplate, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, necklace10, motionScanner, imageItensifier, sightSharpening, ringTemplate, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, ring9, ring10, armorLeather, armorMail, meleeEnhancement, gloveFencing, gloveGauntlet, gloveJousting, hatUshanka, capReinforced, helmArmored, smokingJacket, buckler, shield, shield2, shield3, hammerTemplate, hammer1, hammer2, hammer3, hammerParalyze, hammerSpark, knife, daggerDischarge, sword, swordImpress, swordNullify, halberd, halberd2, halberd3, halberdPushActor, gemTemplate, gem1, gem2, gem3, gem4, gem5, currencyTemplate, currency, jumpingPole, seeingItem]++sandstoneRock,    dart, spike, spike2, slingStone, slingBullet, paralizingProj, harpoon, harpoon2, net, fragmentationBomb, concussionBomb, flashBomb, firecrackerBomb, flaskTemplate, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, flask15, potionTemplate, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, potion11, potion12, potion13, potion14, potion15, scrollTemplate, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, scroll12, scroll13, ediblePlantTemplate, ediblePlant1, ediblePlant2, ediblePlant3, ediblePlant4, ediblePlant5, ediblePlant6, ediblePlant7, light1, light2, light3, blanket, gorget, necklaceTemplate, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, necklace10, motionScanner, imageItensifier, sightSharpening, ringTemplate, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, ring9, ring10, armorLeather, armorMail, meleeEnhancement, gloveFencing, gloveGauntlet, gloveJousting, hatUshanka, capReinforced, helmArmored, smokingJacket, buckler, shield, shield2, shield3, hammerTemplate, hammer1, hammer2, hammer3, hammerParalyze, hammerSpark, knife, daggerDischarge, sword, swordImpress, swordNullify, halberd, halberd2, halberd3, halberdPushActor, gemTemplate, gem1, gem2, gem3, gem4, gem5, currencyTemplate, currency, jumpingPole, seeingItem :: ItemKind++-- Keep the dice rolls and sides in aspects small so that not too many+-- distinct items are generated (for display in item lore and for narrative+-- impact ("oh, I found the more powerful of the two variants of the item!",+-- instead of "hmm, I found one of the countless variants, a decent one").+-- In particular, for unique items, unless they inherit aspects from+-- a standard item, permit only a couple possible variants.+-- This is especially important if an item kind has multiple random aspects.+-- Instead multiply dice results, e.g., (1 `d` 3) * 5 instead of 1 `d` 15.+--+-- Beware of non-periodic non-weapon durable items with beneficial effects+-- and low timeout -- AI will starve applying such an item incessantly.++-- * Item group symbols, partially from Nethack++symbolProjectile, _symbolLauncher, symbolLight, symbolTool, symbolSpecial, symbolGold, symbolNecklace, symbolRing, symbolPotion, symbolFlask, symbolScroll, symbolTorsoArmor, symbolMiscArmor, symbolClothes, symbolShield, symbolPolearm, symbolEdged, symbolHafted, symbolWand, _symbolStaff, symbolFood :: ContentSymbol ItemKind++symbolProjectile = rsymbolProjectile $ ritemSymbols standardRules+_symbolLauncher  = toContentSymbol '}'+symbolLight      = rsymbolLight $ ritemSymbols standardRules+symbolTool       = rsymbolTool $ ritemSymbols standardRules+symbolSpecial    = rsymbolSpecial $ ritemSymbols standardRules+symbolGold       = rsymbolGold $ ritemSymbols standardRules+symbolNecklace   = rsymbolNecklace $ ritemSymbols standardRules+symbolRing       = rsymbolRing $ ritemSymbols standardRules+symbolPotion     = rsymbolPotion $ ritemSymbols standardRules+symbolFlask      = rsymbolFlask $ ritemSymbols standardRules+symbolScroll     = rsymbolScroll $ ritemSymbols standardRules+symbolTorsoArmor = rsymbolTorsoArmor $ ritemSymbols standardRules+symbolMiscArmor  = rsymbolMiscArmor $ ritemSymbols standardRules+symbolClothes    = rsymbolClothes $ ritemSymbols standardRules+symbolShield     = rsymbolShield $ ritemSymbols standardRules+symbolPolearm    = rsymbolPolearm $ ritemSymbols standardRules+symbolEdged      = rsymbolEdged $ ritemSymbols standardRules+symbolHafted     = rsymbolHafted $ ritemSymbols standardRules+symbolWand       = rsymbolWand $ ritemSymbols standardRules+_symbolStaff     = toContentSymbol '_'+symbolFood       = rsymbolFood $ ritemSymbols standardRules++-- ** Thrown weapons++sandstoneRock = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "sandstone rock"+  , ifreq    = [ (S_SANDSTONE_ROCK, 1)+               , (UNREPORTED_INVENTORY, 1) ]  -- too weak to spam+  , iflavour = zipPlain [Green]+  , icount   = 1 + 1 `d` 2  -- > 1, to let AI ignore sole pieces+  , irarity  = [(1, 20), (10, 1)]  -- a few already in starting stash+  , iverbHit = "hit"+  , iweight  = 300+  , idamage  = 1 `d` 1+  , iaspects = [ AddSkill SkHurtMelee $ -16 * 5+               , SetFlag Fragile+               , toVelocity 70 ] -- not dense, irregular+  , ieffects = []+  , idesc    = "A lump of brittle sandstone rock."+  , ikit     = []+  }+dart = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "dart"+  , ifreq    = [(COMMON_ITEM, 100), (ANY_ARROW, 50), (WEAK_ARROW, 50)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1 + 4 `dL` 5+  , irarity  = [(1, 15), (10, 5)]+  , iverbHit = "prick"+  , iweight  = 40+  , idamage  = 1 `d` 1+  , iaspects = [AddSkill SkHurtMelee $ (-15 + 1 `d` 2 + 1 `dL` 3) * 5]+                 -- only good against leather+  , ieffects = []+  , idesc    = "A sharp delicate dart with fins."+  , ikit     = []+  }+spike = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "spike"+  , ifreq    = [(COMMON_ITEM, 100), (ANY_ARROW, 50), (WEAK_ARROW, 50)]+  , iflavour = zipPlain [BrCyan]+  , icount   = 1 + 4 `dL` 5+  , irarity  = [(1, 10), (10, 8)]+  , iverbHit = "nick"+  , iweight  = 150+  , idamage  = 2 `d` 1+  , iaspects = [ AddSkill SkHurtMelee $ (-10 + 1 `d` 2 + 1 `dL` 3) * 5+                   -- heavy vs armor+               , SetFlag MinorEffects+               , toVelocity 70 ]  -- hitting with tip costs speed+  , ieffects = [ Explode S_SINGLE_SPARK  -- when hitting enemy+               , OnSmash (Explode S_SINGLE_SPARK) ]  -- at wall hit+      -- this results in a wordy item synopsis, but it's OK, the spark really+      -- is useful in some situations, not just a flavour+  , idesc    = "A cruel long nail with small head."  -- "Much inferior to arrows though, especially given the contravariance problems."  -- funny, but destroy the suspension of disbelief; this is supposed to be a Lovecraftian horror and any hilarity must ensue from the failures in making it so and not from actively trying to be funny; also, mundane objects are not supposed to be scary or transcendental; the scare is in horrors from the abstract dimension visiting our ordinary reality; without the contrast there's no horror and no wonder, so also the magical items must be contrasted with ordinary XIX century and antique items+  , ikit     = []+  }+spike2 = spike+  { ifreq    = [(COMMON_ITEM, 2), (ANY_ARROW, 1), (WEAK_ARROW, 1)]+  , iflavour = zipPlain [Cyan]+  , iverbHit = "penetrate"+  , iweight  = 200+  , idamage  = 4 `d` 1+  , iaspects = [ AddSkill SkHurtMelee $ (-10 + 1 `d` 2 + 1 `dL` 3) * 5+               , SetFlag MinorEffects+               , Odds (10 * 1 `dL` 10) [] [toVelocity 70] ]+                   -- at deep levels sometimes even don't limit velocity+  , idesc    = "A jagged skewer of rusty metal."+  }+slingStone = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "sling stone"+  , ifreq    = [(COMMON_ITEM, 5), (ANY_ARROW, 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1 + 3 `dL` 4+  , irarity  = [(1, 1), (10, 20)]+  , iverbHit = "batter"+  , iweight  = 200+  , idamage  = 1 `d` 1+  , iaspects = [ AddSkill SkHurtMelee $ (-10 + 1 `d` 2 + 1 `dL` 3) * 5+                   -- heavy, to bludgeon through armor+               , SetFlag MinorEffects+               , toVelocity 150 ]+  , ieffects = [ Explode S_SINGLE_SPARK  -- when hitting enemy+               , OnSmash (Explode S_SINGLE_SPARK) ]  -- at wall hit+  , idesc    = "A round stone, carefully sized and smoothed to fit the pouch of a standard string and cloth sling."+  , ikit     = []+  }+slingBullet = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "sling bullet"+  , ifreq    = [(COMMON_ITEM, 5), (ANY_ARROW, 100)]+  , iflavour = zipPlain [BrBlack]+  , icount   = 1 + 6 `dL` 4+  , irarity  = [(1, 1), (10, 15)]+  , iverbHit = "slug"+  , iweight  = 28+  , idamage  = 1 `d` 1+  , iaspects = [ AddSkill SkHurtMelee $ (-17 + 1 `d` 2 + 1 `dL` 3) * 5+                   -- not too good against armor+               , ToThrow $ ThrowMod 200 100 2  -- piercing+               , SetFlag Fragile ]+                   -- otherwise would rarely break and the player would have+                   -- unlimited resource and would have to pick up constantly+  , ieffects = []+  , idesc    = "Small almond-shaped leaden projectile that weighs more than the sling used to tie the bag. It doesn't drop out of the sling's pouch when swung and doesn't snag when released. Known to pierce through flesh, at least at maximum speed."  -- we lie, it doesn't slow down in our model; but it stops piercing alright+  , ikit     = []+  }++-- ** Exotic thrown weapons++-- Identified, because shape (and name) says it all. Detailed aspects id by use.+-- This is an extremely large value for @Paralyze@. Normally for such values+-- we should instead use condition that disables (almost) all stats,+-- except @SkWait@, so that the player can switch leader and not be+-- helpless nor experience instadeath (unless his party is 1-person+-- or the actor is isolated, but that's usually player's fault).+paralizingProj = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "bolas set"+  , ifreq    = [(COMMON_ITEM, 100)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 1 `dL` 4+  , irarity  = [(5, 5), (10, 5)]+  , iverbHit = "entangle"+  , iweight  = 500+  , idamage  = 1 `d` 1+  , iaspects = [AddSkill SkHurtMelee $ -14 * 5]+  , ieffects = [Paralyze 15, Discharge 1 100]+  , idesc    = "Wood balls tied with hemp rope. The foe is unlikely to use its main weapon while fighting for balance."+  , ikit     = []+  }+harpoon = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "harpoon"+  , ifreq    = [(COMMON_ITEM, 100), (HARPOON, 100)]+  , iflavour = zipPlain [Brown]+  , icount   = 1 `dL` 5+  , irarity  = [(10, 10)]+  , iverbHit = "hook"+  , iweight  = 750+  , idamage  = 5 `d` 1+  , iaspects = [AddSkill SkHurtMelee $ (-10 + 1 `d` 2 + 1 `dL` 3) * 5]+  , ieffects = [ PullActor (ThrowMod 200 50 1)  -- 1 step, fast+               , Yell ]  -- yell, because brutal+  , idesc    = "The cruel, barbed head lodges in its victim so painfully that the weakest tug of the thin line sends the victim flying."+  , ikit     = []+  }+harpoon2 = harpoon+  { iname    = "The whaling Harpoon"+  , ifreq    = [(COMMON_ITEM, 10), (HARPOON, 2)]+  , icount   = 2 `dL` 5+  , iweight  = 1000+  , idamage  = 21 `d` 1+  , iaspects = SetFlag Unique : delete (SetFlag Durable) (iaspects harpoon)+  , idesc    = "With a brittle, barbed head and thick cord, this ancient weapon is designed for formidable prey. The age has made the edge thinner and sharper, but brittle and splintering, so it won't last beyond a single hit. "+  }+net = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "net"+  , ifreq    = [(COMMON_ITEM, 100)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 1 `dL` 3+  , irarity  = [(5, 5), (10, 7)]+  , iverbHit = "entangle"+  , iweight  = 1000+  , idamage  = 2 `d` 1+  , iaspects = [AddSkill SkHurtMelee $ -14 * 5]+  , ieffects = [ toOrganBad S_SLOWED (3 + 1 `d` 3)+               , DropItem maxBound 1 CEqp ARMOR_LOOSE+                   -- only one of each kind is dropped, because no rubbish+                   -- in this group and so no risk of exploit+               , SendFlying (ThrowMod 100 50 1) ]  -- 1 step; painful+  , idesc    = "A wide net with weights along the edges. Entangles armor and restricts movement."+  , ikit     = []+  }++-- ** Explosives, with the only effect being @Explode@++fragmentationBomb = ItemKind+  { isymbol  = symbolProjectile+  , iname    = "clay pot"+      -- clay pot filled with black powder; fragmentation comes from the clay+      -- shards, so it's not obvious if it's a weapon or just storage method;+      -- deflagration, not detonation, so large mass and hard container+      -- required not to burn harmlessly; improvised short fuze+  , ifreq    = [(COMMON_ITEM, 100), (EXPLOSIVE, 200)]+  , iflavour = zipPlain [Red]+  , icount   = 1 `dL` 5  -- many, because not very intricate+  , irarity  = [(5, 8), (10, 5)]+  , iverbHit = "thud"+  , iweight  = 3000  -- low velocity due to weight+  , idamage  = 0  -- heavy and hard, but let's not confuse with blast damage+  , iaspects = [ ELabel "of black powder"+               , SetFlag Lobable, SetFlag Fragile ]+  , ieffects = [ Explode S_FOCUSED_FRAGMENTATION+               , OnSmash (Explode S_VIOLENT_FRAGMENTATION) ]+  , idesc    = "The practical application of science."+  , ikit     = []+  }+concussionBomb = fragmentationBomb+  { iname    = "satchel"+      -- slightly stabilized nitroglycerine in a soft satchel, hence+      -- no fragmentation, but huge shock wave despite small size and lack of+      -- strong container to build up pressure (hence only mild hearing loss);+      -- indoors helps the shock wave; unstable enough that no fuze required+  , iflavour = zipPlain [Magenta]+  , iverbHit = "flap"+  , iweight  = 400+  , iaspects = [ ELabel "of mining charges"+               , SetFlag Lobable, SetFlag Fragile+               , toVelocity 70 ]  -- flappy and so slow+  , ieffects = [ Explode S_FOCUSED_CONCUSSION+               , OnSmash (Explode S_VIOLENT_CONCUSSION) ]+  , idesc    = "Avoid sudden movements."+  }+-- Not flashbang, because powerful bang without fragmentation is harder+-- to manufacture (requires an oxidizer and steel canister with holes).+-- The bang would also paralyze and/or lower the movement skill+-- (out of balance due to ear trauma).+flashBomb = fragmentationBomb+  { iname    = "magnesium ribbon"  -- filled with magnesium flash powder+  , iflavour = zipPlain [BrYellow]  -- avoid @BrWhite@; looks wrong in dark+  , iverbHit = "flash"+  , iweight  = 400+  , iaspects = [ SetFlag Lobable, SetFlag Fragile+               , toVelocity 70 ]  -- bad shape for throwing+  , ieffects = [Explode S_FOCUSED_FLASH, OnSmash (Explode S_VIOLENT_FLASH)]+  , idesc    = "For dramatic entrances and urgent exits."+  }+firecrackerBomb = fragmentationBomb+  { iname = "roll"  -- not fireworks, as they require outdoors+  , iflavour = zipPlain [BrMagenta]+  , irarity  = [(1, 5), (5, 6)]  -- a toy, if harmful+  , iverbHit = "crack"  -- a pun, matches the verb from "ItemKindBlast"+  , iweight  = 1000+  , iaspects = [SetFlag Lobable, SetFlag Fragile]+  , ieffects = [Explode S_FIRECRACKER, OnSmash (Explode S_FIRECRACKER)]+  , idesc    = "String and paper, concealing a deadly surprise."+  }++-- ** Exploding consumables.++-- Not identified, because they are perfect for the id-by-use fun,+-- due to effects. They are fragile and upon hitting the ground explode+-- for effects roughly corresponding to their normal effects.+-- Whether to hit with them or explode them close to the target+-- is intended to be an interesting tactical decision.++-- Flasks are intended to be thrown. They are often not natural: maths, magic,+-- distillery. In fact, they cover all temporary conditions, except those+-- for stats resistance and regeneration. They never heal, directly+-- nor indirectly (regen), so may be thrown without the risk of wasting+-- precious HP.+--+-- There is no flask nor condition that only does Calm or max Calm depletion,+-- because Calm reduced often via combat, etc.++flaskTemplate = ItemKind+  { isymbol  = symbolFlask+  , iname    = "flask"+  , ifreq    = [(FLASK_UNKNOWN, 1)]+  , iflavour = zipGlassPlain darkCol ++ zipGlassFancy darkCol+               ++ zipLiquid darkCol+  , icount   = 1 `dL` 3+  , irarity  = [(1, 7), (10, 3)]+  , iverbHit = "splash"+  , iweight  = 500+  , idamage  = 0+  , iaspects = [ PresentAs FLASK_UNKNOWN, SetFlag Lobable, SetFlag Fragile+               , toVelocity 60 ]  -- oily, rather bad grip+  , ieffects = []+  , idesc    = "A flask of oily liquid of a suspect color. Something seems to be moving inside. Double dose causes twice longer effect. Triple dose is not advisable, since the active substance is never without unhealty side-efects and often dissolved in large volumes of alcohol."+  , ikit     = []+  }+flask1 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , icount   = 1 `dL` 5+  , irarity  = [(10, 10)]+  , iaspects = ELabel "of strength brew"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_STRENGTHENED (20 + 1 `d` 5)+               , OnSmash (Explode S_DENSE_SHOWER) ]+  }+flask2 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of weakness brew"+               : iaspects flaskTemplate+  , ieffects = [ toOrganBad S_WEAKENED (20 + 1 `d` 5)+               , OnSmash (Explode S_SPARSE_SHOWER) ]+  }+flask3 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of melee protective balm"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_PROTECTED_FROM_MELEE (20 + 1 `d` 5)+               , OnSmash (Explode S_MELEE_PROTECTIVE_BALM) ]+  }+flask4 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of ranged protective balm"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_PROTECTED_FROM_RANGED (20 + 1 `d` 5)+               , OnSmash (Explode S_RANGE_PROTECTIVE_BALM) ]+  }+flask5 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of PhD defense questions"+               : iaspects flaskTemplate+  , ieffects = [ toOrganBad S_DEFENSELESS (20 + 1 `d` 5)+               , Impress+               , Detect DetectExit 20+               , OnSmash (Explode S_DEFENSELESSNESS_RUNOUT) ]+  }+flask6 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , irarity  = [(1, 1)]  -- not every playthrough needs one+  , iaspects = ELabel "of resolution"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_RESOLUTE (100 + 1 `d` 20)  -- long, for scouting+               , RefillCalm 100  -- not to make it a drawback, via @calmEnough@+               , OnSmash (Explode S_RESOLUTION_DUST) ]+  }+flask7 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , icount   = 1 `d` 2  -- too powerful en masse+  , iaspects = ELabel "of haste brew"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_HASTED (20 + 1 `d` 5)+               , OnSmash (Explode S_HASTE_SPRAY) ]+  }+flask8 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of eye drops"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_FAR_SIGHTED (40 + 1 `d` 10)+               , OnSmash (Explode S_EYE_DROP) ]+  }+flask9 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , irarity  = [(10, 2)]  -- not very useful right now+  , iaspects = ELabel "of smelly concoction"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_KEEN_SMELLING (40 + 1 `d` 10)+               , Detect DetectActor 10  -- make it at least slightly useful+               , OnSmash (Explode S_SMELLY_DROPLET) ]+  }+flask10 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , irarity  = [(10, 2)]  -- not very useful right now+  , iaspects = ELabel "of cat tears"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_SHINY_EYED (40 + 1 `d` 10)+               , OnSmash (Explode S_EYE_SHINE) ]+  }+flask11 = flaskTemplate+  { iname    = "bottle"+  , ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , icount   = 1 `d` 3  -- the only one sometimes giving away its identity+  , iaspects = ELabel "of whiskey"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_DRUNK (20 + 1 `d` 5)+               , Burn 10, RefillHP 10, Yell+               , OnSmash (Explode S_WHISKEY_SPRAY) ]+  }+flask12 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of bait cocktail"+               : iaspects flaskTemplate+  , ieffects = [ toOrganGood S_DRUNK (20 + 1 `d` 5)+               , Burn 1, RefillHP 3  -- risky exploit possible, good+               , Summon MOBILE_ANIMAL 1+               , OnSmash (Summon MOBILE_ANIMAL 1)+               , OnSmash Impress  -- mildly useful when thrown+               , OnSmash (Explode S_WASTE) ]+  }+flask13 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of poison"+               : iaspects flaskTemplate+  , ieffects = [ toOrganNoTimer S_POISONED, toOrganNoTimer S_POISONED  -- x2+               , OnSmash (Explode S_POISON_CLOUD) ]+  }+flask14 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of calamity"+               : iaspects flaskTemplate+  , ieffects = [ toOrganNoTimer S_POISONED+               , toOrganBad S_WEAKENED (20 + 1 `d` 5)+               , toOrganBad S_DEFENSELESS (20 + 1 `d` 5)+               , OnSmash (Explode S_GLASS_HAIL) ]  -- enough glass to cause that+  }+flask15 = flaskTemplate+  { ifreq    = [ (COMMON_ITEM, 100), (ANY_FLASK, 100), (EXPLOSIVE, 100)+               , (ANY_GLASS, 100) ]+  , iaspects = ELabel "of snail gel"+               : iaspects flaskTemplate+  , ieffects = [ toOrganBad S_SLOWED (3 + 1 `d` 3)+               , OnSmash (Explode S_FOCUSED_SLOWNESS_MIST) ]+  }++-- Potions are often not intended to be thrown. They are usually natural,+-- including natural stat boosts. They also include the only healing+-- consumables in the game, apart of elixirs and, to a limited extent, fruits.+-- They appear deeper than most flasks. Various configurations of effects.+-- A different class of effects is on scrolls and mechanical items.+-- Some are shared.++potionTemplate = ItemKind+  { isymbol  = symbolPotion+  , iname    = "potion"+  , ifreq    = [(POTION_UNKNOWN, 1)]+  , iflavour = zipLiquid brightCol ++ zipPlain brightCol ++ zipFancy brightCol+  , icount   = 1 `dL` 3+  , irarity  = [(1, 10), (10, 6)]+  , iverbHit = "splash"+  , iweight  = 200+  , idamage  = 0+  , iaspects = [ PresentAs POTION_UNKNOWN, SetFlag Lobable, SetFlag Fragile+               , toVelocity 50 ]  -- oily, small momentum due to small size+  , ieffects = []+  , idesc    = "A vial of bright, frothing concoction. The best medicine that nature has to offer for wounds, ailments and mood swings."+  , ikit     = []+  }+potion1 = potionTemplate+  { iname    = "vial"+  , ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , icount   = 3 `dL` 1  -- very useful, despite appearances+  , iaspects = ELabel "of rose water"+               : iaspects potionTemplate+  , ieffects = [ Impress, toOrganGood S_ROSE_SMELLING (50 + 1 `d` 10)+               , OnSmash ApplyPerfume, OnSmash (Explode S_FRAGRANCE) ]+  }+potion2 = potionTemplate+  { iname    = "the Potion"+  , ifreq    = [(TREASURE, 100), (ANY_GLASS, 100)]+  , icount   = 1+  , irarity  = [(5, 8), (10, 8)]+  , iaspects = [SetFlag Unique, ELabel "of Attraction", SetFlag MetaGame]+               ++ iaspects potionTemplate+  , ieffects = [ Dominate+               , toOrganGood S_HASTED (20 + 1 `d` 5)+               , OnSmash (Explode S_PHEROMONE)+               , OnSmash (Explode S_HASTE_SPRAY) ]+  , idesc    = "The liquid fizzes with energy."+  }+potion3 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , ieffects = [ RefillHP 5, DropItem 1 maxBound COrgan S_POISONED+               , OnSmash (Explode S_HEALING_MIST) ]+  }+potion4 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(1, 6), (10, 10)]+  , ieffects = [ RefillHP 10+               , DropItem maxBound maxBound COrgan CONDITION+               , OnSmash (Explode S_HEALING_MIST_2) ]+  }+potion5 = potionTemplate+  { iname    = "ampoule"  -- probably filled with nitroglycerine, but let's+                          -- not mix fantasy with too much technical jargon+  , ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , icount   = 3 `dL` 1+  , ieffects = [ DropItem 1 maxBound COrgan CONDITION+               , OnSmash (Explode S_VIOLENT_CONCUSSION) ]+      -- not fragmentation nor glass hail, because not enough glass+  }+potion6 = potionTemplate+  -- needs to be common to show at least a portion of effects+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , icount   = 3 `dL` 1  -- always as many as possible on this level+                         -- without giving away potion identity+  , irarity  = [(1, 12)]+  , ieffects = [ OneOf [ RefillHP 10, RefillHP 5, Burn 5+                       , DropItem 1 maxBound COrgan S_POISONED+                       , toOrganGood S_STRENGTHENED (20 + 1 `d` 5) ]+               , OnSmash (OneOf [ Explode S_DENSE_SHOWER+                                , Explode S_SPARSE_SHOWER+                                , Explode S_MELEE_PROTECTIVE_BALM+                                , Explode S_RANGE_PROTECTIVE_BALM+                                , Explode S_DEFENSELESSNESS_RUNOUT ]) ]+  }+potion7 = potionTemplate+  -- needs to be common to show at least a portion of effects+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , icount   = 3 `dL` 1+  , irarity  = [(10, 10)]+  , ieffects = [ Impress+               , OneOf [ RefillHP 20, RefillHP 10, Burn 10+                       , DropItem 1 maxBound COrgan S_POISONED+                       , toOrganGood S_HASTED (20 + 1 `d` 5)+                       , toOrganBad S_IMPATIENT (2 + 1 `d` 2) ]+               , OnSmash (OneOf [ Explode S_HEALING_MIST_2+                                , Explode S_WOUNDING_MIST+                                , Explode S_DISTRESSING_ODOR+                                , Explode $ blastNoStatOf S_IMPATIENT+                                , Explode S_HASTE_SPRAY+                                , Explode S_VIOLENT_SLOWNESS_MIST+                                , Explode S_FRAGRANCE+                                , Explode S_VIOLENT_FLASH ]) ]+  }+potion8 = potionTemplate+  { iname    = "the Potion"+  , ifreq    = [(TREASURE, 100), (ANY_GLASS, 100)]+  , icount   = 1+  , irarity  = [(10, 5)]+  , iaspects = [SetFlag Unique, ELabel "of Love", SetFlag MetaGame]+               ++ iaspects potionTemplate+  , ieffects = [ RefillHP 60, RefillCalm (-60)+               , toOrganGood S_ROSE_SMELLING (80 + 1 `d` 20)+               , OnSmash (Explode S_HEALING_MIST_2)+               , OnSmash (Explode S_DISTRESSING_ODOR) ]+  , idesc    = "Perplexing swirls of intense, compelling colour."+  }+potion9 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(10, 5)]+  , iaspects = ELabel "of grenadier focus"+               : iaspects potionTemplate+  , ieffects = [ toOrganGood S_MORE_PROJECTING (40 + 1 `d` 10)+               , toOrganBad S_PACIFIED (5 + 1 `d` 3)+                   -- the malus has to be weak, or would be too good+                   -- when thrown at foes+               , OnSmash (Explode $ blastBonusStatOf S_MORE_PROJECTING)+               , OnSmash (Explode $ blastNoStatOf S_PACIFIED) ]+  , idesc    = "Thick, sluggish fluid with violently-bursting bubbles."+  }+potion10 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(10, 8)]+  , iaspects = ELabel "of frenzy"+               : iaspects potionTemplate+  , ieffects = [ Yell+               , toOrganGood S_STRENGTHENED (20 + 1 `d` 5)+               , toOrganBad S_RETAINING (5 + 1 `d` 3)+               , toOrganBad S_FRENZIED (40 + 1 `d` 10)+               , OnSmash (Explode S_DENSE_SHOWER)+               , OnSmash (Explode $ blastNoStatOf S_RETAINING)    -- more+               , OnSmash (Explode $ blastNoStatOf S_RETAINING) ]  -- explosion+  }+potion11 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(10, 8)]+  , iaspects = ELabel "of panic"+               : iaspects potionTemplate+  , ieffects = [ RefillCalm (-30)+               , toOrganGood S_HASTED (20 + 1 `d` 5)+               , toOrganBad S_WEAKENED (20 + 1 `d` 5)+               , toOrganBad S_WITHHOLDING (10 + 1 `d` 5)+               , OnSmash (Explode S_HASTE_SPRAY)+               , OnSmash (Explode S_SPARSE_SHOWER)+               , OnSmash (Explode $ blastNoStatOf S_WITHHOLDING) ]+  }+potion12 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(10, 8)]+  , iaspects = ELabel "of quicksilver"+               : iaspects potionTemplate+  , ieffects = [ toOrganGood S_HASTED (20 + 1 `d` 5)+               , toOrganBad S_BLIND (10 + 1 `d` 5)+               , toOrganBad S_IMMOBILE (5 + 1 `d` 5)+               , OnSmash (Explode S_HASTE_SPRAY)+               , OnSmash (Explode S_IRON_FILING)+               , OnSmash (Explode $ blastNoStatOf S_IMMOBILE) ]+  }+potion13 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(10, 4)]+  , iaspects = ELabel "of slow resistance"+               : iaspects potionTemplate+  , ieffects = [ toOrganNoTimer S_SLOW_RESISTANT+               , OnSmash (Explode S_ANTI_SLOW_MIST) ]+  }+potion14 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(10, 4)]+  , iaspects = ELabel "of poison resistance"+               : iaspects potionTemplate+  , ieffects = [ toOrganNoTimer S_POISON_RESISTANT+               , OnSmash (Explode S_ANTIDOTE_MIST) ]+  }+-- The player has full control over throwing the potion at his party,+-- so he can milk the explosion, so it has to be much weaker, so a weak+-- healing effect is enough. OTOH, throwing a harmful flask at many enemies+-- at once is not easy to arrange, so these explosions can stay powerful.+potion15 = potionTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_POTION, 100), (ANY_GLASS, 100)]+  , irarity  = [(1, 2), (10, 12)]+  , iaspects = ELabel "of regeneration"+               : iaspects potionTemplate+  , ieffects = [ toOrganGood S_ROSE_SMELLING (80 + 1 `d` 20)+               , toOrganNoTimer S_REGENERATING+               , toOrganNoTimer S_REGENERATING  -- x2+               , OnSmash (Explode S_YOUTH_SPRINKLE) ]+  }++-- ** Non-exploding consumables, not specifically designed for throwing++-- Readable or otherwise communicating consumables require high apply skill+-- to be consumed.++scrollTemplate = ItemKind+  { isymbol  = symbolScroll+  , iname    = "scroll"+  , ifreq    = [(SCROLL_UNKNOWN, 1)]+  , iflavour = zipFancy stdCol ++ zipPlain stdCol+  , icount   = 1 `dL` 3+  , irarity  = [(1, 14), (10, 7)]+  , iverbHit = "thump"+  , iweight  = 50+  , idamage  = 0+  , iaspects = [ PresentAs SCROLL_UNKNOWN+               , toVelocity 30 ]  -- bad shape, even rolled up+  , ieffects = []+  , idesc    = "Scraps of haphazardly scribbled mysteries from beyond. Is this equation an alchemical recipe? Is this diagram an extradimensional map? Is this formula a secret call sign?"+  , ikit     = []+  }+scroll1 = scrollTemplate+  { iname    = "the Scroll"+  , ifreq    = [(TREASURE, 100), (ANY_SCROLL, 100)]+  , icount   = 1+  , irarity  = [(5, 9), (10, 9)]  -- mixed blessing, so found early for a unique+  , iaspects = [SetFlag Unique, ELabel "of Reckless Beacon"]+               ++ iaspects scrollTemplate+  , ieffects = [Summon HERO 1, Summon MOBILE_ANIMAL (2 + 1 `d` 2)]+  , idesc    = "The bright flame and sweet-smelling smoke of this heavily infused scroll should attract natural creatures inhabiting the area, including human survivors, if any."+  }+scroll2 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , irarity  = [(1, 6), (10, 2)]+  , ieffects = [Ascend False]+  }+scroll3 = scrollTemplate+  -- needs to be common to show at least a portion of effects+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , icount   = 3 `dL` 1+  , irarity  = [(1, 14)]+  , ieffects = [OneOf [ Teleport 5, Paralyze 10, InsertMove 30+                      , Detect DetectEmbed 12, Detect DetectHidden 20 ]]+  }+scroll4 = scrollTemplate+  -- needs to be common to show at least a portion of effects+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , icount   = 3 `dL` 1+  , irarity  = [(10, 14)]+  , ieffects = [ Impress+               , OneOf [ Teleport 20, Ascend False, Ascend True+                       , OneOf [Summon HERO 1, Summon MOBILE_ANIMAL $ 1 `d` 2]+                           -- gaining a hero particularly uncommon+                       , Detect DetectLoot 20  -- the most useful of detections+                       , CreateItem Nothing CGround COMMON_ITEM timerNone ] ]+  }+scroll5 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , irarity  = [(1, 6)]  -- powerful, but low counts at the depths it appears on+  , ieffects = [InsertMove $ 20 + 1 `dL` 20]+  }+scroll6 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , irarity  = [(10, 11)]+  , ieffects = [PullActor (ThrowMod 800 75 1)]  -- 6 steps, 1.5 turns+  }+scroll7 = scrollTemplate+  { iname    = "the Scroll"+  , ifreq    = [(TREASURE, 100), (ANY_SCROLL, 100)]+  , icount   = 1+  , irarity  = [(10, 12)]+  , iaspects = [SetFlag Unique, ELabel "of Rescue Proclamation"]+               ++ iaspects scrollTemplate+  , ieffects = [Summon HERO 1]+  , idesc    = "A survivor of past exploration missions is found that enjoys, apparently, complete physiological integrity. We can pronounce him a comrade in arms and let him join our party."+  }+scroll8 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , irarity  = [(10, 4)]  -- powerful, even if not ideal; scares newbies+  , ieffects = [Detect DetectAll 20]+  }+scroll9 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , iaspects = ELabel "of cue interpretation"+               : iaspects scrollTemplate+  , ieffects = [Detect DetectActor 20]+  }+scroll10 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , icount   = 3 `dL` 1+  , irarity  = [(1, 20)]  -- uncommon deep down, where all is known+  , iaspects = ELabel "of scientific explanation"+               : iaspects scrollTemplate+  , ieffects = [Identify `AndEffect` RefillCalm 10]+  , idesc    = "The most pressing existential concerns are met with a deeply satisfying scientific answer."+  }+scroll11 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , irarity  = [(10, 20)]  -- at gameover a crucial item may be missing+  , iaspects = ELabel "of transmutation"+               : iaspects scrollTemplate+  , ieffects = [PolyItem `AndEffect` Explode S_FIRECRACKER]+  }+scroll12 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , irarity  = [(10, 15)]+  , iaspects = ELabel "of transfiguration"+               : iaspects scrollTemplate+  , ieffects = [RerollItem]+  }+scroll13 = scrollTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_SCROLL, 100)]+  , irarity  = [(10, 15)]+  , iaspects = ELabel "of similarity"+               : iaspects scrollTemplate+  , ieffects = [DupItem]+  }++-- Foods require only minimal apply skill to consume. Many animals can eat them.++ediblePlantTemplate = ItemKind+  { isymbol  = symbolFood+  , iname    = "edible plant"+  , ifreq    = [(EDIBLE_PLANT_UNKNOWN, 1)]+  , iflavour = zipFancy stdCol+  , icount   = 1 `dL` 5+  , irarity  = [(1, 12), (10, 6)]  -- let's feed the animals+  , iverbHit = "thump"+  , iweight  = 50+  , idamage  = 0+  , iaspects = [ PresentAs EDIBLE_PLANT_UNKNOWN+               , toVelocity 30 ]  -- low density, often falling apart+  , ieffects = []+  , idesc    = "Withered but fragrant bits of a colorful plant. Taste tolerably and break down easily, but only eating may reveal the full effects."+  , ikit     = []+  }+ediblePlant1 = ediblePlantTemplate+  { iname    = "overripe berry"+  , ifreq    = [(COMMON_ITEM, 100), (EDIBLE_PLANT, 100)]+  , ieffects = [RefillHP 1, toOrganBad S_IMMOBILE (5 + 1 `d` 5)]+  }+ediblePlant2 = ediblePlantTemplate+  { iname    = "frayed fungus"+  , ifreq    = [(COMMON_ITEM, 100), (EDIBLE_PLANT, 100)]+  , ieffects = [toOrganNoTimer S_POISONED]+  }+ediblePlant3 = ediblePlantTemplate+  { iname    = "thick leaf"+  , ifreq    = [(COMMON_ITEM, 100), (EDIBLE_PLANT, 100)]+  , ieffects = [DropItem 1 maxBound COrgan S_POISONED]+  }+ediblePlant4 = ediblePlantTemplate+  { iname    = "shrunk fruit"+  , ifreq    = [(COMMON_ITEM, 100), (EDIBLE_PLANT, 100)]+  , ieffects = [toOrganBad S_BLIND (10 + 1 `d` 10)]+  }+ediblePlant5 = ediblePlantTemplate+  { iname    = "fragrant herb"+  , ifreq    = [(COMMON_ITEM, 100), (EDIBLE_PLANT, 100)]+  , icount   = 1 `dL` 9+  , irarity  = [(1, 12), (10, 5)]+  , iaspects = ELabel "of lethargy"+               : iaspects ediblePlantTemplate+  , ieffects = [ toOrganBad S_SLOWED (20 + 1 `d` 5)+               , toOrganNoTimer S_REGENERATING+               , toOrganNoTimer S_REGENERATING  -- x2+               , RefillCalm 5 ]+  }+ediblePlant6 = ediblePlantTemplate+  { iname    = "dull flower"+  , ifreq    = [(COMMON_ITEM, 100), (EDIBLE_PLANT, 100)]+  , ieffects = [PutToSleep]+  }+ediblePlant7 = ediblePlantTemplate+  { iname    = "spicy bark"+  , ifreq    = [(COMMON_ITEM, 100), (EDIBLE_PLANT, 100)]+  , ieffects = [InsertMove 20, toOrganBad S_FRENZIED (40 + 1 `d` 10)]+  }++-- ** Lights++light1 = ItemKind+  { isymbol  = symbolLight+  , iname    = "wooden torch"+  , ifreq    = [ (COMMON_ITEM, 100), (LIGHT_ATTENUATOR, 100)+               , (S_WOODEN_TORCH, 1) ]+  , iflavour = zipPlain [Brown]+  , icount   = 1 `dL` 4+  , irarity  = [(1, 40), (4, 1)]+  , iverbHit = "scorch"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = [ AddSkill SkShine 3  -- no malus, to lessen micromanagement+               , SetFlag Lobable, SetFlag Equipable+               , EqpSlot EqpSlotShine ]+                   -- not Fragile; reusable flare+  , ieffects = [Burn 1]+  , idesc    = "A heavy smoking wooden torch, improvised using a cloth soaked in tar, burning in an unsteady glow."+  , ikit     = []+  }+light2 = ItemKind+  { isymbol  = symbolLight+  , iname    = "oil lamp"+  , ifreq    = [(COMMON_ITEM, 100), (LIGHT_ATTENUATOR, 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1 `dL` 2+  , irarity  = [(4, 10)]+  , iverbHit = "burn"+  , iweight  = 1500+  , idamage  = 1 `d` 1+  , iaspects = [ AddSkill SkShine 3+               , SetFlag Lobable, SetFlag Fragile, SetFlag Equipable+               , EqpSlot EqpSlotShine ]+  , ieffects = [ Explode S_FOCUSED_BURNING_OIL_2+               , OnSmash (Explode S_VIOLENT_BURNING_OIL_2) ]+  , idesc    = "A small clay lamp filled with plant oil feeding a tiny wick."+  , ikit     = []+  }+light3 = ItemKind+  { isymbol  = symbolLight+  , iname    = "brass lantern"+  , ifreq    = [(COMMON_ITEM, 100), (LIGHT_ATTENUATOR, 100)]+  , iflavour = zipPlain [Red]+  , icount   = 1+  , irarity  = [(10, 6)]+  , iverbHit = "burn"+  , iweight  = 3000+  , idamage  = 2 `d` 1+  , iaspects = [ AddSkill SkShine 4+               , SetFlag Lobable, SetFlag Fragile, SetFlag Equipable+               , EqpSlot EqpSlotShine ]+  , ieffects = [ Explode S_FOCUSED_BURNING_OIL_4+               , OnSmash (Explode S_VIOLENT_BURNING_OIL_4) ]+  , idesc    = "Very bright and very heavy brass lantern."+  , ikit     = []+  }+blanket = ItemKind+  { isymbol  = symbolLight+  , iname    = "wool blanket"+  , ifreq    = [ (COMMON_ITEM, 100), (LIGHT_ATTENUATOR, 100)+               , (FIREPROOF_CLOTH, 1) ]+  , iflavour = zipPlain [BrBlack]+  , icount   = 1+  , irarity  = [(1, 1)]  -- not every playthrough needs one+  , iverbHit = "swoosh"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = [ AddSkill SkShine (-10)+               , AddSkill SkArmorMelee 3, AddSkill SkMaxCalm 5+               , SetFlag Lobable, SetFlag Equipable+               , EqpSlot EqpSlotArmorMelee ]+                   -- not Fragile; reusable douse implement;+                   -- douses torch, lamp and lantern in one action,+                   -- both in equipment and when thrown at the floor+  , ieffects = []+  , idesc    = "Warm, comforting, and concealing, woven from soft wool."+  , ikit     = []+  }++-- ** Periodic jewelry++-- This looks like a necklace, but is not periodic. Instead, it auto-activates+-- when under melee attack.+gorget = necklaceTemplate+  { iname    = "Old Gorget"+  , ifreq    = [(COMMON_ITEM, 25), (TREASURE, 25)]+  , iflavour = zipFancy [BrCyan]  -- looks exactly the same as one of necklaces,+                                  -- but it's OK, it's an artifact+  , iaspects = [ SetFlag Unique+               , Timeout $ 7 - 1 `dL` 4+                   -- the dL dice need to be in negative positions+                   -- for negative stats, such as @Timeout@, so that+                   -- the @RerollItem@ effect makes the item better, not worse+               , AddSkill SkArmorMelee 3, AddSkill SkHearing 3+               , SetFlag UnderMelee, SetFlag Durable ]+               ++ delete (SetFlag Periodic) iaspects_necklaceTemplate+  , ieffects = [RefillCalm 15]+  , idesc    = "Highly ornamental, cold, large steel medallion on a chain. Unlikely to offer much protection as an armor piece, but the old worn engraving reassures the wearer."+  }+-- Morally these are the aspects, but we also need to add a fake @Timeout@,+-- to let clients know that the not identified item is periodic jewelry.+iaspects_necklaceTemplate :: [Aspect]+iaspects_necklaceTemplate =+  [ PresentAs NECKLACE_UNKNOWN+  , SetFlag Periodic, SetFlag Precious, SetFlag Equipable+  , toVelocity 50 ]  -- not dense enough+-- Not identified, because id by use, e.g., via periodic activations. Fun.+necklaceTemplate = ItemKind+  { isymbol  = symbolNecklace+  , iname    = "necklace"+  , ifreq    = [(NECKLACE_UNKNOWN, 1)]+  , iflavour = zipFancy stdCol ++ zipPlain brightCol+  , icount   = 1+  , irarity  = [(4, 3), (10, 6)]+  , iverbHit = "whip"+  , iweight  = 30+  , idamage  = 0+  , iaspects = Timeout 1000000+                 -- fake, needed to display "charging"; the timeout itself+                 -- won't be displayed thanks to periodic; as a side-effect,+                 -- it can't be activated until identified, which is better+                 -- than letting the player try to activate before the real+                 -- cooldown is over and waste turn+               : iaspects_necklaceTemplate+  , ieffects = []+  , idesc    = "Menacing Greek symbols shimmer with increasing speed along a chain of fine encrusted links. After a tense build-up, a prismatic arc shoots towards the ground and the iridescence subdues, becomes ordered and resembles a harmless ornament again, for a time."+  , ikit     = []+  }+necklace1 = necklaceTemplate+  { iname    = "the Necklace"+  , ifreq    = [(TREASURE, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(10, 3)]+  , iaspects = [ SetFlag Unique, ELabel "of Aromata"+               , Timeout $ (4 - 1 `dL` 3) * 10+                   -- priceless, so worth the long wait and Calm drain+               , SetFlag Durable ]+               ++ iaspects_necklaceTemplate+  , ieffects = [ RefillCalm (-5)+               , When (TriggeredBy ActivationPeriodic) $ RefillHP 1 ]+  , idesc    = "A cord of freshly dried herbs and healing berries."+  }+necklace2 = necklaceTemplate+  { iname    = "the Necklace"+  , ifreq    = [(TREASURE, 100), (ANY_JEWELRY, 100)]+      -- too nasty to call it just a COMMON_ITEM+  , irarity  = [(10, 3)]+  , iaspects = [ SetFlag Unique, ELabel "of Live Bait"+               , Timeout 30+               , AddSkill SkOdor 2+               , SetFlag Durable ]+               ++ iaspects_necklaceTemplate+  , ieffects = [ DropItem 1 1 COrgan CONDITION  -- mildly useful when applied+               , When (TriggeredBy ActivationPeriodic) $ SeqEffect+                   [ Impress+                   , Summon MOBILE_ANIMAL $ 1 `dL` 2+                   , Explode S_WASTE ] ]+  , idesc    = "A cord hung with lumps of decaying meat. It's better not to think about the source."+  }+necklace3 = necklaceTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , iaspects = [ ELabel "of fearful listening"+               , Timeout 40+                   -- has to be larger than Calm drain or item not removable;+                   -- equal is not enough if enemies drained Calm already+               , AddSkill SkHearing 6 ]+               ++ iaspects_necklaceTemplate+  , ieffects = [ Detect DetectActor 20  -- can be applied; destroys the item+               , When (TriggeredBy ActivationPeriodic) $ RefillCalm (-30) ]+  }+necklace4 = necklaceTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , iaspects = [ ELabel "of escape"+               , Timeout $ (7 - 1 `dL` 5) * 10 ]+               ++ iaspects_necklaceTemplate+  , ieffects = [ Teleport $ 14 + 3 `d` 3  -- can be applied; destroys the item+               , Detect DetectExit 20+               , Yell ]  -- drawback when used for quick exploring+  , idesc    = "A supple chain that slips through your fingers."+  }+necklace5 = necklaceTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , iaspects = [ ELabel "of greed"+               , Timeout ((2 + 1 `d` 3) * 10) ]+               ++ iaspects_necklaceTemplate+  , ieffects = [ Detect DetectLoot 20+               , toOrganBad S_PARSIMONIOUS (5 + 1 `d` 3)  -- hard to flee+               , When (TriggeredBy ActivationPeriodic) $ Teleport 40 ]  -- risky+  }+necklace6 = necklaceTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , iaspects = Timeout ((3 + 1 `d` 3 - 1 `dL` 3) * 2)+               : iaspects_necklaceTemplate  -- OP if Durable; free blink+  , ieffects = [Teleport $ 3 `d` 2]+  }+necklace7 = necklaceTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , iaspects = Timeout ((1 `d` 3) * 2)+               : iaspects_necklaceTemplate+  , ieffects = [PushActor (ThrowMod 100 50 1)]  -- 1 step, slow+                  -- the @50@ is only for the case of very light actor, etc.+  }+necklace8 = necklaceTemplate+  { iname    = "the Necklace"+  , ifreq    = [(TREASURE, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(10, 1)]  -- different gameplay for the actor that wears it+  , iaspects = [ SetFlag Unique, ELabel "of Overdrive"+               , Timeout 4+               , AddSkill SkMaxHP 25  -- give incentive to cope with impatience+               , SetFlag Durable ]+               ++ iaspects_necklaceTemplate+  , ieffects = [ InsertMove $ 9 + 1 `d` 11  -- unpredictable+               , toOrganBad S_IMPATIENT 4]+                 -- The same duration as timeout, to avoid spurious messages+                 -- as well as unlimited accumulation of the duration.+  , idesc    = "A string of beads in various colours, with no discernable pattern."+  }+necklace9 = necklaceTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(4, 3)]  -- entirely optional+  , iaspects = Timeout ((1 + 1 `d` 3) * 5)  -- low timeout for offensive use+               : iaspects_necklaceTemplate+  , ieffects = [Explode S_SPARK]+  }+necklace10 = necklaceTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , iaspects = Timeout ((3 + 1 `d` 3) * 10)+               : iaspects_necklaceTemplate+                   -- high timeout to prevent spam obscuring messages+                   -- when other actors act and annoying bumping into+                   -- projectiles caused by own necklace when walking+  , ieffects = [Explode S_FRAGRANCE]+  }+motionScanner = necklaceTemplate+  { iname    = "draft detector"+  , ifreq    = [(COMMON_ITEM, 100), (ADD_NOCTO_1, 20)]+  , irarity  = [(5, 2)]+  , iverbHit = "jingle"+  , iweight  = 300  -- almost gives it away+  , iaspects = [ Timeout $ 4 + 1 `dL` 6+                   -- positive dL dice, since the periodic effect is detrimental+               , AddSkill SkNocto 1+               , AddSkill SkArmorMelee $ (-4 + 1 `dL` 3) * 5+               , EqpSlot EqpSlotMiscBonus ]+               ++ iaspects_necklaceTemplate+  , ieffects = [Explode S_PING_PLASH]+  , idesc    = "A silk flag with a bell for detecting sudden draft changes. May indicate a nearby corridor crossing or a fast enemy approaching in the dark. The bell is very noisy and casts light reflection flashes."+  }++-- ** Non-periodic jewelry++imageItensifier = ItemKind+  { isymbol  = symbolRing+  , iname    = "light cone"+  , ifreq    = [(TREASURE, 100), (ADD_NOCTO_1, 80)]+  , iflavour = zipFancy [BrYellow]+  , icount   = 1+  , irarity  = [(5, 2)]+  , iverbHit = "bang"+  , iweight  = 500+  , idamage  = 0+  , iaspects = [ AddSkill SkNocto 1+               , AddSkill SkArmorMelee $ (-6 + 1 `dL` 3) * 5+               , SetFlag Precious, SetFlag Equipable+               , EqpSlot EqpSlotMiscBonus ]+  , ieffects = []+  , idesc    = "Contraption of lenses and mirrors on a polished brass headband for capturing and strengthening light in dark environment. Hampers vision in daylight. Stackable."+  , ikit     = []+  }+sightSharpening = ringTemplate  -- small and round, so mistaken for a ring+  { iname    = "sharp monocle"+  , ifreq    = [(TREASURE, 20), (ADD_SIGHT, 1)]+      -- it's has to be very rare, because it's powerful and not unique,+      -- and also because it looks exactly as one of necklaces, so it would+      -- be misleading when seen on the map+  , irarity  = [(7, 1), (10, 12)]  -- low @ifreq@+  , iweight  = 50  -- heavier that it looks, due to glass+  , iaspects = [ AddSkill SkSight $ 1 + 1 `dL` 2+               , AddSkill SkHurtMelee $ (1 `d` 3) * 3+               , EqpSlot EqpSlotSight ]+               ++ iaspects ringTemplate+  , idesc    = "Lets you better focus your weaker eye."+  }+-- Don't add standard effects to rings, because they go in and out+-- of eqp and so activating them would require UI tedium: looking for+-- them in eqp and stash or even activating a wrong item by mistake.+--+-- By general mechanisms, due to not having effects that could identify+-- them by observing the effect, rings are identified on pickup.+-- That's unlike necklaces, which provide the fun of id-by-use, because they+-- have effects and when the effects are triggered, they get identified.+ringTemplate = ItemKind+  { isymbol  = symbolRing+  , iname    = "ring"+  , ifreq    = [(RING_UNKNOWN, 1)]+  , iflavour = zipPlain stdCol ++ zipFancy darkCol+  , icount   = 1+  , irarity  = [(10, 2)]  -- the default very low+  , iverbHit = "knock"+  , iweight  = 15+  , idamage  = 0+  , iaspects = [PresentAs RING_UNKNOWN, SetFlag Precious, SetFlag Equipable]+  , ieffects = []+  , idesc    = "It looks like an ordinary object, but it's in fact a generator of exceptional effects: adding to some of your natural qualities and subtracting from others."+  , ikit     = []+  }+ring1 = ringTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(8, 4)]+  , iaspects = [ AddSkill SkSpeed $ 1 `dL` 2+               , AddSkill SkMaxHP (-20)+               , EqpSlot EqpSlotSpeed ]+               ++ iaspects ringTemplate+  }+ring2 = ringTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(8, 4)]+  , iaspects = [ AddSkill SkSpeed $ 1 + 1 `dL` 3+               , AddSkill SkArmorMelee (-40)+               , EqpSlot EqpSlotSpeed ]+               ++ iaspects ringTemplate+  }+ring3 = ringTemplate+  { iname    = "the Ring"+  , ifreq    = [(TREASURE, 100), (ANY_JEWELRY, 100)]+  , iaspects = [ SetFlag Unique, ELabel "of Rush"+               , AddSkill SkSpeed $ (1 + 1 `dL` 2) * 2+               , AddSkill SkMaxHP (-20)+               , AddSkill SkArmorMelee (-20)+               , SetFlag Durable, EqpSlot EqpSlotSpeed ]+               ++ iaspects ringTemplate+  , idesc    = "Roughly-shaped metal with shallow scratches marking it."+  }+ring4 = ringTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(3, 4), (10, 8)]+  , iaspects = [ AddSkill SkHurtMelee $ (2 + 1 `d` 3 + (1 `dL` 2) * 2 ) * 3+               , AddSkill SkMaxHP (-10)+               , EqpSlot EqpSlotHurtMelee ]+               ++ iaspects ringTemplate+  }+ring5 = ringTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , iaspects = [ AddSkill SkHurtMelee $ (4 + 1 `d` 3 + (1 `dL` 2) * 2 ) * 3+               , AddSkill SkArmorMelee (-20)+               , EqpSlot EqpSlotHurtMelee ]+               ++ iaspects ringTemplate+  }+ring6 = ringTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(10, 8)]+  , iaspects = [ AddSkill SkMaxHP $ 5 + (1 `d` 2 + 1 `dL` 2) * 5+               , AddSkill SkMaxCalm $ -30 + (1 `dL` 3) * 5+               , EqpSlot EqpSlotMaxHP ]+               ++ iaspects ringTemplate+  }+ring7 = ringTemplate+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(5, 1), (10, 9)]  -- needed after other items drop Calm+  , iaspects = [ AddSkill SkMaxCalm $ 30 + (1 `dL` 4) * 5+               , AddSkill SkHearing 6+               , EqpSlot EqpSlotMiscBonus ]+               ++ iaspects ringTemplate+  , idesc    = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words."+  }+ring8 = ringTemplate  -- weak skill per eqp slot, so can be without drawbacks+  { ifreq    = [(COMMON_ITEM, 100), (ANY_JEWELRY, 100)]+  , irarity  = [(10, 3)]+  , iaspects = [ AddSkill SkShine 1+               , EqpSlot EqpSlotShine ]+               ++ iaspects ringTemplate+  , idesc    = "A sturdy ring with a large, shining stone."+  }+ring9 = ringTemplate+  { ifreq    = [(RING_OF_OPPORTUNITY_SNIPER, 1) ]  -- only for scenarios+  , irarity  = [(1, 1)]+  , iaspects = [ ELabel "of opportunity sniper"+               , AddSkill SkProject 8+               , EqpSlot EqpSlotProject ]+               ++ iaspects ringTemplate+  }+ring10 = ringTemplate+  { ifreq    = [(RING_OF_OPPORTUNITY_GRENADIER, 1) ]  -- only for scenarios+  , irarity  = [(1, 1)]+  , iaspects = [ ELabel "of opportunity grenadier"+               , AddSkill SkProject 11+               , EqpSlot EqpSlotProject ]+               ++ iaspects ringTemplate+  }++-- ** Armor++armorLeather = ItemKind+  { isymbol  = symbolTorsoArmor+  , iname    = "leather armor"+  , ifreq    = [(COMMON_ITEM, 100), (ARMOR_LOOSE, 1), (STARTING_ARMOR, 100)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(1, 9), (10, 2)]+  , iverbHit = "thud"+  , iweight  = 7000+  , idamage  = 0+  , iaspects = [ AddSkill SkHurtMelee (-2)+               , AddSkill SkArmorMelee $ (2 + 1 `dL` 4) * 5+               , AddSkill SkArmorRanged $ (1 + 1 `dL` 2) * 3+               , SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotArmorMelee ]+  , ieffects = []+  , idesc    = "A stiff jacket formed from leather boiled in bee wax, padded linen and horse hair. Protects from anything that is not too sharp. Smells much better than the rest of your garment."+  , ikit     = []+  }+armorMail = armorLeather+  { iname    = "ring armor"+  , ifreq    = [ (COMMON_ITEM, 100), (ARMOR_LOOSE, 1), (ARMOR_RANGED, 50)+               , (STARTING_ARMOR, 50) ]+  , iflavour = zipPlain [Cyan]+  , irarity  = [(6, 9), (10, 3)]+  , iweight  = 12000+  , idamage  = 0+  , iaspects = [ AddSkill SkHurtMelee (-3)+               , AddSkill SkArmorMelee $ (2 + 1 `dL` 4) * 5+               , AddSkill SkArmorRanged $ (4 + 1 `dL` 2) * 3+               , AddSkill SkOdor 2+               , SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotArmorRanged ]+  , ieffects = []+  , idesc    = "A long shirt with tiny iron rings sewn into it. Discourages foes from attacking your torso, especially with ranged weapons, which can't pierce the rings nor aim between them. The stiff fabric is hard to wash, though."+  }+meleeEnhancement = ItemKind+  { isymbol  = symbolTool+  , iname    = "whetstone"+  , ifreq    = [(COMMON_ITEM, 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(10, 10)]+  , iverbHit = "smack"+  , iweight  = 400+  , idamage  = 0+  , iaspects = [ AddSkill SkHurtMelee $ (1 `dL` 7) * 5+               , AddSkill SkArmorMelee 2+               , SetFlag Equipable, EqpSlot EqpSlotHurtMelee ]+  , ieffects = []+  , idesc    = "A portable sharpening stone for keeping your weapons keen and true, without the need to set up camp, fish out tools and assemble a proper sharpening workshop. Provides an extra polish to amor, as well."+  , ikit     = []+  }+gloveFencing = ItemKind+  { isymbol  = symbolMiscArmor+  , iname    = "leather glove"+  , ifreq    = [ (COMMON_ITEM, 100), (ARMOR_MISC, 1), (ARMOR_RANGED, 50)+               , (STARTING_ARMOR, 50) ]+  , iflavour = zipPlain [White]+  , icount   = 1+  , irarity  = [(5, 9), (10, 9)]+  , iverbHit = "flap"+  , iweight  = 100+  , idamage  = 1 `d` 1+  , iaspects = [ AddSkill SkHurtMelee $ (2 + 1 `d` 2 + 1 `dL` 2) * 3+               , AddSkill SkArmorRanged $ (1 `dL` 2) * 3+               , SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotHurtMelee+               , toVelocity 50 ]  -- flaps and flutters+  , ieffects = []+  , idesc    = "A fencing glove from rough leather ensuring a good grip. Also quite effective in averting or even catching slow projectiles."+  , ikit     = []+  }+gloveGauntlet = gloveFencing+  { iname    = "steel gauntlet"+  , ifreq    = [(COMMON_ITEM, 100), (ARMOR_MISC, 1), (STARTING_ARMOR, 50)]+  , iflavour = zipPlain [BrCyan]+  , irarity  = [(1, 9), (10, 3)]+  , iverbHit = "mow"+  , iweight  = 300+  , idamage  = 2 `d` 1+  , iaspects = [ AddSkill SkArmorMelee $ (1 + 1 `dL` 4) * 5+               , SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotArmorMelee+               , toVelocity 50 ]  -- flaps and flutters+  , idesc    = "Long leather gauntlet covered in overlapping steel plates."+  }+gloveJousting = gloveFencing+  { iname    = "Tournament Gauntlet"+  , ifreq    = [(COMMON_ITEM, 100), (ARMOR_MISC, 1)]+  , iflavour = zipFancy [BrRed]+  , irarity  = [(1, 3), (10, 3)]+  , iverbHit = "ram"+  , iweight  = 3000+  , idamage  = 3 `d` 1+  , iaspects = [ SetFlag Unique+               , AddSkill SkHurtMelee $ (-7 + 1 `dL` 5) * 3+               , AddSkill SkArmorMelee $ (2 + 1 `d` 2 + 1 `dL` 2) * 5+               , AddSkill SkArmorRanged $ (1 + 1 `dL` 2) * 3+                 -- very random on purpose and can even be good on occasion+                 -- or when ItemRerolled enough times+               , SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotArmorMelee+               , toVelocity 50 ]  -- flaps and flutters+  , idesc    = "Rigid, steel jousting handgear. If only you had a lance. And a horse to carry it all."+  }+hatUshanka = ItemKind+  { isymbol  = symbolMiscArmor+  , iname    = "ushanka hat"+  , ifreq    = [ (COMMON_ITEM, 100), (ARMOR_MISC, 1), (CLOTHING_MISC, 1)+               , (STARTING_ARMOR, 50) ]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(1, 6), (10, 1)]+  , iverbHit = "tickle"+  , iweight  = 500+  , idamage  = 0+  , iaspects = [ Timeout $ (2 + 1 `d` 2) * 3+               , AddSkill SkArmorMelee 5, AddSkill SkHearing (-6)+               , SetFlag Periodic, SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotArmorMelee+               , toVelocity 50 ]  -- flaps and flutters+  , ieffects = [RefillCalm 1]+  , idesc    = "Soft and warm fur. It keeps your ears warm."+  , ikit     = []+  }+capReinforced = ItemKind+  { isymbol  = symbolMiscArmor+  , iname    = "leather cap"+  , ifreq    = [(COMMON_ITEM, 100), (ARMOR_MISC, 1), (STARTING_ARMOR, 50)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(6, 9), (10, 3)]+  , iverbHit = "cut"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = [ AddSkill SkArmorMelee $ (1 `d` 2) * 5+               , AddSkill SkProject 1+                   -- the brim shields against blinding by light sources, etc.+               , SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotProject ]+  , ieffects = []+  , idesc    = "Boiled leather with a wide brim. It might soften a blow."+  , ikit     = []+  }+helmArmored = ItemKind+  { isymbol  = symbolMiscArmor+  , iname    = "bucket helm"+  , ifreq    = [(COMMON_ITEM, 100), (ARMOR_MISC, 1), (STARTING_ARMOR, 50)]+  , iflavour = zipPlain [BrCyan]+  , icount   = 1+  , irarity  = [(6, 9), (10, 3)]+  , iverbHit = "bounce"+  , iweight  = 2000+  , idamage  = 0+  , iaspects = [ AddSkill SkArmorMelee $ (1 + 1 `dL` 4) * 5+               , AddSkill SkArmorRanged $ (2 + 1 `dL` 2) * 3  -- headshot+               , AddSkill SkSight (-2)+               , AddSkill SkHearing (-3), AddSkill SkSmell (-5)+               , SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotArmorRanged ]+  , ieffects = []+  , idesc    = "Blocks out everything, including your senses."+  , ikit     = []+  }+smokingJacket = ItemKind+  { isymbol  = symbolClothes+  , iname    = "smoking jacket"+  , ifreq    = [(COMMON_ITEM, 100), (CLOTHING_MISC, 1), (CHIC_GEAR, 100)]+  , iflavour = zipFancy [BrGreen]+  , icount   = 1+  , irarity  = [(1, 9), (10, 3)]+  , iverbHit = "stroke"+  , iweight  = 5000+  , idamage  = 0+  , iaspects = [ Timeout $ (1 `d` 2) * 3+               , AddSkill SkSpeed 2+               , AddSkill SkOdor 2+               , SetFlag Periodic, SetFlag Durable, SetFlag Equipable+               , EqpSlot EqpSlotSpeed ]+  , ieffects = [RefillCalm 1]+  , idesc    = "Wearing this velvet jacket, anyone would look dashing."+  , ikit     = []+  }+-- Shield doesn't protect against ranged attacks to prevent+-- micromanagement: walking with shield, melee without.+-- Their biggest power is pushing enemies, which however reduces+-- to 1 extra damage point if no clear space behind enemy.+-- So they require keen tactical management.+-- Note that AI will pick them up but never wear and will use them at most+-- as a way to push itself. Despite being @Meleeable@, they will not be used+-- as weapons either. This is OK, using shields smartly is totally beyond AI.+buckler = ItemKind+  { isymbol  = symbolShield+  , iname    = "buckler"+  , ifreq    = [(COMMON_ITEM, 100), (ARMOR_LOOSE, 1)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(4, 5)]+  , iverbHit = "bash"+  , iweight  = 2000+  , idamage  = 0  -- safe to be used on self+  , iaspects = [ Timeout $ (3 + 1 `d` 3 - 1 `dL` 3) * 2+               , AddSkill SkArmorMelee 40+                   -- not enough to compensate; won't be in AI's eqp+               , AddSkill SkHurtMelee (-30)+                   -- too harmful; won't be wielded as weapon+               , SetFlag Durable, SetFlag Meleeable+               , EqpSlot EqpSlotArmorMelee ]+  , ieffects = [PushActor (ThrowMod 200 50 1)]  -- 1 step, fast+  , idesc    = "Heavy and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too small to intercept projectiles with. May serve as a counterweight to suddenly push forth."+  , ikit     = []+  }+shield = buckler+  { iname    = "shield"+  , irarity  = [(8, 4)]  -- the stronger variants add to total probability+  , iflavour = zipPlain [Green]+  , iweight  = 4000+  , idamage  = 4 `d` 1+  , iaspects = [ Timeout $ (3 + 1 `d` 3 - 1 `dL` 3) * 4+               , AddSkill SkArmorMelee 80+                   -- not enough to compensate; won't be in AI's eqp+               , AddSkill SkHurtMelee (-70)+                   -- too harmful; won't be wielded as weapon+               , SetFlag Durable, SetFlag Meleeable+               , EqpSlot EqpSlotArmorMelee+               , toVelocity 50 ]  -- unwieldy to throw+  , ieffects = [PushActor (ThrowMod 400 50 1)]  -- 2 steps, fast+  , idesc    = "Large and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too heavy to intercept projectiles with. Useful to push foes out of the way."+  }+shield2 = shield+  { ifreq    = [(COMMON_ITEM, 3 * 3)]  -- very low base rarity+  , iweight  = 5000+  , idamage  = 8 `d` 1+  , idesc    = "A relic of long-past wars, heavy and with a central spike."+  }+shield3 = shield2+  { ifreq    = [(COMMON_ITEM, 1 * 3)]  -- very low base rarity+  , iweight  = 6000+  , idamage  = 12 `d` 1+  }++-- ** Weapons++knife = ItemKind+  { isymbol  = symbolEdged+  , iname    = "dagger"+  , ifreq    = [(COMMON_ITEM, 100), (STARTING_WEAPON, 200)]+  , iflavour = zipPlain [BrCyan]+  , icount   = 1+  , irarity  = [(2, 45), (4, 1)]+  , iverbHit = "cut"+  , iweight  = 800+  , idamage  = 6 `d` 1+  , iaspects = [ Timeout 2+               , AddSkill SkHurtMelee $ (-1 + 1 `d` 2 + 1 `dL` 2) * 3+               , AddSkill SkArmorMelee $ (1 `d` 2) * 5+                   -- very common, so don't make too random+               , SetFlag Durable, SetFlag Meleeable+               , EqpSlot EqpSlotWeaponFast+               , toVelocity 40 ]  -- ensuring it hits with the tip costs speed+  , ieffects = []+  , idesc    = "A short dagger for thrusting and parrying blows. Does not penetrate deeply, but is quick to move and hard to block. Especially useful in conjunction with a larger weapon."+  , ikit     = []+  }+daggerDischarge = knife+  { iname    = "The Double Dagger"+  , ifreq    = [(TREASURE, 20)]+  , irarity  = [(1, 3), (10, 3)]+  , iaspects = SetFlag Unique+               : iaspects knife+  , ieffects = [Discharge 1 50, Yell]  -- powerful and low timeout, but noisy+                                       -- and no effect if no weapons charged+  , idesc    = "A double dagger that a focused fencer can use to catch and twist away an opponent's blade."+  }+hammerTemplate = ItemKind+  { isymbol  = symbolHafted+  , iname    = "war hammer"+  , ifreq    = [(HAMMER_UNKNOWN, 1)]+  , iflavour = zipFancy [BrMagenta]  -- avoid "pink"+  , icount   = 1+  , irarity  = [(3, 25), (5, 1)]+  , iverbHit = "club"+  , iweight  = 1600+  , idamage  = 8 `d` 1  -- we are lying about the dice here, but the dungeon+                        -- is too small and the extra-dice hammers too rare+                        -- to subdivide this identification class by dice+  , iaspects = [ PresentAs HAMMER_UNKNOWN+               , SetFlag Durable, SetFlag Meleeable+               , toVelocity 40 ]  -- ensuring it hits with the tip costs speed+  , ieffects = []+  , idesc    = "It may not cause extensive wounds, but neither does it harmlessly glance off heavy armour as blades and polearms tend to. There are so many shapes and types, some looking more like tools than weapons, that at a glance you can't tell what a particular specimen does. It's obvious, though, that any of them requires some time to recover after a swing."  -- if it's really the average kind, the weak kind, the description stays; if not, it's replaced with one of the descriptions below at identification time+  , ikit     = []+  }+hammer1 = hammerTemplate+  { ifreq    = [(COMMON_ITEM, 100), (STARTING_WEAPON, 70)]+  , iaspects = [Timeout 5, EqpSlot EqpSlotWeaponBig]+               ++ iaspects hammerTemplate+  }+hammer2 = hammerTemplate+  { ifreq    = [(COMMON_ITEM, 20), (STARTING_WEAPON, 7)]+  , iverbHit = "gouge"+  , iaspects = [Timeout 3, EqpSlot EqpSlotWeaponFast]+               ++ iaspects hammerTemplate+  , idesc    = "Upon closer inspection, this hammer turns out particularly handy and well balanced, with one thick and sturdy and two long and sharp points compensating the modest size."+  }+hammer3 = hammerTemplate+  { ifreq    = [(COMMON_ITEM, 3), (STARTING_WEAPON, 1)]+  , iverbHit = "puncture"+  , iweight  = 2400+  , idamage  = 12 `d` 1+  , iaspects = [ Timeout 12  -- balance, or @DupItem@ would break the game+               , SetFlag MetaGame  -- weight gives it away after seen once+               , EqpSlot EqpSlotWeaponBig]+               ++ iaspects hammerTemplate+  , idesc    = "This hammer sports a long metal handle that increases the momentum of the sharpened head's swing, at the cost of long recovery."+  }+hammerParalyze = hammerTemplate+  { iname    = "The Brute Hammer"+  , ifreq    = [(TREASURE, 20)]+  , irarity  = [(5, 1), (8, 6)]+  , iaspects = [ SetFlag Unique+               , Timeout 5+               , EqpSlot EqpSlotWeaponBig ]+               ++ iaspects hammerTemplate+  , ieffects = [Paralyze 10]+  , idesc    = "A huge shapeless lump of meteorite iron alloy on a sturdy pole. Nobody remains standing when this head connects."+  }+hammerSpark = hammerTemplate+  { iname    = "The Grand Smithhammer"+  , ifreq    = [(TREASURE, 20)]+  , irarity  = [(5, 1), (8, 6)]+  , iweight  = 2400+  , idamage  = 12 `d` 1+  , iaspects = [ SetFlag Unique+               , SetFlag MetaGame  -- weight gives it away after seen once+               , Timeout 10+               , EqpSlot EqpSlotWeaponBig+               , AddSkill SkShine 3]+               ++ iaspects hammerTemplate+  , ieffects = [Explode S_SPARK]+      -- we can't use a focused explosion, because it would harm the hammer+      -- wielder as well, unlike this one+  , idesc    = "Smiths of old wielded this heavy hammer and its sparks christened many a potent blade."+  }+sword = ItemKind+  { isymbol  = symbolEdged+  , iname    = "sword"+  , ifreq    = [(COMMON_ITEM, 100), (STARTING_WEAPON, 30)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(4, 1), (6, 15)]+  , iverbHit = "slash"+  , iweight  = 2000+  , idamage  = 10 `d` 1+  , iaspects = [ Timeout 7+               , SetFlag Durable, SetFlag Meleeable+               , EqpSlot EqpSlotWeaponBig+               , toVelocity 40 ]  -- ensuring it hits with the tip costs speed+  , ieffects = []+  , idesc    = "Difficult to master; deadly when used effectively. The steel is particularly hard and keen, but rusts quickly without regular maintenance."+  , ikit     = []+  }+swordImpress = sword+  { iname    = "The Master's Sword"+  , ifreq    = [(TREASURE, 20)]+  , irarity  = [(5, 1), (8, 6)]+  , iaspects = SetFlag Unique+               : iaspects sword+  , ieffects = [Impress]+  , idesc    = "A particularly well-balance blade, lending itself to impressive shows of fencing skill."+  }+swordNullify = sword+  { iname    = "The Gutting Sword"+  , ifreq    = [(TREASURE, 20)]+  , iverbHit = "pierce"+  , irarity  = [(5, 1), (8, 6)]+  , iaspects = [SetFlag Unique, Timeout 3, EqpSlot EqpSlotWeaponFast]+               ++ (iaspects sword \\ [Timeout 7, EqpSlot EqpSlotWeaponBig])+  , ieffects = [ DropItem 1 maxBound COrgan CONDITION+               , RefillCalm (-10)+               , Yell ]+  , idesc    = "Cold, thin blade that pierces deeply and sends its victim into abrupt, sobering shock."+  }+halberd = ItemKind+  { isymbol  = symbolPolearm+  , iname    = "war scythe"+  , ifreq    = [(COMMON_ITEM, 100), (STARTING_WEAPON, 20)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(5, 1), (8, 12)]+  , iverbHit = "impale"+  , iweight  = 3000+  , idamage  = 12 `d` 1+  , iaspects = [ Timeout 10+               , AddSkill SkHurtMelee $ (-5 + 1 `dL` 3) * 5+                   -- useless against armor at game start+               , AddSkill SkArmorMelee 20+               , SetFlag Durable, SetFlag Meleeable+               , EqpSlot EqpSlotWeaponBig+               , toVelocity 20 ]  -- not balanced+  , ieffects = []+  , idesc    = "An improvised weapon made of scythe's blade attached to a long pole. Not often one succeeds in making enough space to swing it freely, but even when stuck between terrain obstacles it blocks approaches effectively and makes using other weapons difficult, both by friends and foes."+  , ikit     = []+  }+halberd2 = halberd+  { iname    = "halberd"+  , ifreq    = [(COMMON_ITEM, 3 * 2), (STARTING_WEAPON, 1)]+  , iweight  = 4000+  , iaspects = AddSkill SkHurtMelee ((-6 + 1 `dL` 4) * 10)+                 -- balance, or @DupItem@ would break the game;+                 -- together with @RerollItem@, it's allowed to, though+               : (iaspects halberd+                  \\ [AddSkill SkHurtMelee $ (-6 + 1 `dL` 4) * 5])+  , idamage  = 18 `d` 1+  , idesc    = "A long haft with a sharp blade. Designed and refined for war."+  }+halberd3 = halberd2+  { iname    = "bardiche"+  , ifreq    = [(COMMON_ITEM, 1 * 2)]  -- compensating for low base rarity+  , iverbHit = "carve"+  , iweight  = 5000+  , idamage  = 24 `d` 1+  , idesc    = "The reach of a spear but the edge of an axe."+  }+halberdPushActor = halberd+  { iname    = "The Swiss Halberd"+  , ifreq    = [(TREASURE, 20)]+  , irarity  = [(7, 0), (9, 15)]+  , iaspects = SetFlag Unique+               : iaspects halberd+  , ieffects = [PushActor (ThrowMod 200 100 1)]  -- 2 steps, slow+  , idesc    = "A versatile polearm, with great reach and leverage. Foes are held at a distance."+  }++-- ** Treasure++gemTemplate = ItemKind+  { isymbol  = symbolGold+  , iname    = "gem"+  , ifreq    = [(GEM_UNKNOWN, 1), (VALUABLE, 100)]+  , iflavour = zipPlain $ delete BrYellow brightCol  -- natural, so not fancy+  , icount   = 1+  , irarity  = [(3, 0), (10, 24)]+  , iverbHit = "tap"+  , iweight  = 50+  , idamage  = 0+  , iaspects = [PresentAs GEM_UNKNOWN, SetFlag Precious]+  , ieffects = []+  , idesc    = "Useless, and still worth around 100 gold each. Would gems of thought and pearls of artful design be valued that much in our age of Science and Progress!"+  , ikit     = []+  }+gem1 = gemTemplate+  { ifreq    = [ (TREASURE, 100), (GEM, 100), (ANY_JEWELRY, 10)+               , (VALUABLE, 100) ]+  , irarity  = [(3, 0), (6, 12), (10, 8)]+  , iaspects = [AddSkill SkShine 1, AddSkill SkSpeed (-1)]+                 -- reflects strongly, distracts; so it glows in the dark,+                 -- is visible on dark floor, but not too tempting to wear+               ++ iaspects gemTemplate+  }+gem2 = gem1+  { ifreq    = [ (TREASURE, 150), (GEM, 100), (ANY_JEWELRY, 10)+               , (VALUABLE, 100) ]+  , irarity  = [(5, 0), (7, 25), (10, 8)]+  }+gem3 = gem1+  { ifreq    = [ (TREASURE, 150), (GEM, 100), (ANY_JEWELRY, 10)+               , (VALUABLE, 100) ]+  , irarity  = [(7, 0), (8, 20), (10, 8)]+  }+gem4 = gem1+  { ifreq    = [ (TREASURE, 150), (GEM, 100), (ANY_JEWELRY, 30)+               , (VALUABLE, 100) ]+  , irarity  = [(9, 0), (10, 70)]+  }+gem5 = gem1+  { isymbol  = symbolSpecial+  , iname    = "elixir"+  , ifreq    = [ (TREASURE, 100), (GEM, 25), (ANY_JEWELRY, 10)+               , (VALUABLE, 100) ]+  , iflavour = zipPlain [BrYellow]+  , irarity  = [(1, 40), (10, 10)]+  , iaspects = [ ELabel "of youth", SetFlag Precious  -- not hidden+               , AddSkill SkOdor (-1) ]+  , ieffects = [RefillCalm 10, RefillHP 40]+  , idesc    = "A crystal vial of amber liquid, supposedly granting eternal youth and fetching 100 gold per piece. The main effect seems to be mild euphoria, but it admittedly smells good and heals minor ailments rather well."+  }+currencyTemplate = ItemKind+  { isymbol  = symbolGold+  , iname    = "gold piece"+  , ifreq    = [(CURRENCY_UNKNOWN, 1), (VALUABLE, 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 10 + 1 `d` 20 + 1 `dL` 20+  , irarity  = [(1, 25), (10, 10)]+  , iverbHit = "tap"+  , iweight  = 31+  , idamage  = 0+  , iaspects = [PresentAs CURRENCY_UNKNOWN, SetFlag Precious]+  , ieffects = []+  , idesc    = "Reliably valuable in every civilized plane of existence."+  , ikit     = []+  }+currency = currencyTemplate+  { ifreq    = [(TREASURE, 100), (S_CURRENCY, 100), (VALUABLE, 1)]+  , iaspects = [AddSkill SkShine 1, AddSkill SkSpeed (-1)]+               ++ iaspects currencyTemplate+  }++-- ** Tools to be actively used, but not worn++jumpingPole = ItemKind+  { isymbol  = symbolWand+  , iname    = "jumping pole"+  , ifreq    = [(COMMON_ITEM, 90)]+  , iflavour = zipFancy [White]+  , icount   = 1+  , irarity  = [(1, 3)]+  , iverbHit = "prod"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [ Timeout $ (2 + 1 `d` 2 - 1 `dL` 2) * 5+               , SetFlag Durable ]+  , ieffects = [toOrganGood S_HASTED 1]+                 -- This works and doesn't cause AI loops. @InsertMove@+                 -- would produce an activation that doesn't change game state.+                 -- Hasting for an absolute number of turns would cause+                 -- an explosion of time when several poles are accumulated.+                 -- Here it speeds AI up for exactly the turn spent activating,+                 -- so when AI applies it repeatedly, it gets its time back and+                 -- is not stuck. In total, the exploration speed is unchanged,+                 -- but it's useful when fleeing in the dark to make distance+                 -- and when initiating combat, so it's OK that AI uses it.+                 -- Timeout is rather high, because for factions with leaders+                 -- some time is often gained, so this could be useful+                 -- even during melee, which would be tiresome to employ.+  , idesc    = "Makes you vulnerable at take-off, but then you are free like a bird."+  , ikit     = []+  }+seeingItem = ItemKind+  { isymbol  = symbolFood+  , iname    = "giant pupil"+  , ifreq    = [(COMMON_ITEM, 100)]+  , iflavour = zipPlain [Red]+  , icount   = 1+  , irarity  = [(1, 2)]+  , iverbHit = "gaze at"+  , iweight  = 100+  , idamage  = 0+  , iaspects = [ Timeout 3+               , AddSkill SkSight 10  -- a spyglass for quick wields+               , AddSkill SkMaxCalm 30  -- to diminish clipping sight by Calm+               , AddSkill SkShine 2  -- to lit corridors when flying+               , SetFlag Periodic ]+  , ieffects = [ Detect DetectActor 20  -- rare enough+               , When (TriggeredBy ActivationPeriodic) $ SeqEffect+                   [ toOrganNoTimer S_POISONED  -- really can't be worn+                   , Summon MOBILE_MONSTER 1 ] ]+  , idesc    = "A slimy, dilated green pupil torn out from some giant eye. Clear and focused, as if still alive."   , ikit     = []   }
GameDefinition/Content/ItemKindActor.hs view
@@ -1,279 +1,700 @@ -- | Actor (or rather actor body trunk) definitions.-module Content.ItemKindActor ( actors ) where+module Content.ItemKindActor+  ( -- * Group name patterns+    pattern S_WOODEN_TORCH, pattern S_SANDSTONE_ROCK+  , pattern HERO, pattern SCOUT_HERO, pattern RANGER_HERO, pattern ESCAPIST_HERO, pattern AMBUSHER_HERO, pattern BRAWLER_HERO, pattern SOLDIER_HERO, pattern CIVILIAN, pattern MONSTER, pattern MOBILE_MONSTER, pattern SCOUT_MONSTER, pattern ANIMAL, pattern MOBILE_ANIMAL, pattern IMMOBILE_ANIMAL, pattern INSECT, pattern GEOPHENOMENON+  , pattern ADD_SIGHT, pattern ARMOR_RANGED, pattern ADD_NOCTO_1, pattern WEAK_ARROW, pattern LIGHT_ATTENUATOR, pattern FIREPROOF_CLOTH, pattern RING_OF_OPPORTUNITY_SNIPER, pattern ANY_ARROW, pattern STARTING_ARMOR, pattern STARTING_WEAPON, pattern GEM+  , actorsGN, actorsGNSingleton+  , -- * Content+    actors+  ) where -import qualified Data.EnumMap.Strict as EM+import Prelude () -import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Core.Prelude+ import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Definition.Ability+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal+import Game.LambdaHack.Definition.Flavour +import Content.ItemKindOrgan++-- * Group name patterns++actorsGNSingleton :: [GroupName ItemKind]+actorsGNSingleton =+       [S_WOODEN_TORCH, S_SANDSTONE_ROCK]++pattern S_WOODEN_TORCH, S_SANDSTONE_ROCK :: GroupName ItemKind++actorsGN :: [GroupName ItemKind]+actorsGN =+       [HERO, SCOUT_HERO, RANGER_HERO, ESCAPIST_HERO, AMBUSHER_HERO, BRAWLER_HERO, SOLDIER_HERO, CIVILIAN, MONSTER, MOBILE_MONSTER, SCOUT_MONSTER, ANIMAL, MOBILE_ANIMAL, IMMOBILE_ANIMAL, INSECT, GEOPHENOMENON]+    ++ [ADD_SIGHT, ARMOR_RANGED, ADD_NOCTO_1, WEAK_ARROW, LIGHT_ATTENUATOR, FIREPROOF_CLOTH, RING_OF_OPPORTUNITY_SNIPER, ANY_ARROW, STARTING_ARMOR, STARTING_WEAPON, GEM]++pattern HERO, SCOUT_HERO, RANGER_HERO, ESCAPIST_HERO, AMBUSHER_HERO, BRAWLER_HERO, SOLDIER_HERO, CIVILIAN, MONSTER, MOBILE_MONSTER, SCOUT_MONSTER, ANIMAL, MOBILE_ANIMAL, IMMOBILE_ANIMAL, INSECT, GEOPHENOMENON :: GroupName ItemKind++pattern ADD_SIGHT, ARMOR_RANGED, ADD_NOCTO_1, WEAK_ARROW, LIGHT_ATTENUATOR, FIREPROOF_CLOTH, RING_OF_OPPORTUNITY_SNIPER, ANY_ARROW, STARTING_ARMOR, STARTING_WEAPON, GEM :: GroupName ItemKind++pattern HERO = GroupName "adventurer"+pattern SCOUT_HERO = GroupName "scout"+pattern RANGER_HERO = GroupName "ranger"+pattern ESCAPIST_HERO = GroupName "escapist"+pattern AMBUSHER_HERO = GroupName "ambusher"+pattern BRAWLER_HERO = GroupName "brawler"+pattern SOLDIER_HERO = GroupName "soldier"+pattern CIVILIAN = GroupName "civilian"+pattern MONSTER = GroupName "monstrosity"+pattern MOBILE_MONSTER = GroupName "mobile monstrosity"+pattern SCOUT_MONSTER = GroupName "scout monstrosity"+pattern ANIMAL = GroupName "animal"+pattern MOBILE_ANIMAL = GroupName "mobile animal"+pattern IMMOBILE_ANIMAL = GroupName "immobile animal"+pattern INSECT = GroupName "insect"+pattern GEOPHENOMENON = GroupName "geological phenomenon"++pattern S_WOODEN_TORCH = GroupName "wooden torch"+pattern S_SANDSTONE_ROCK = GroupName "sandstone rock"++pattern ADD_SIGHT = GroupName "sight improvement"+pattern ARMOR_RANGED = GroupName "ranged armor"+pattern ADD_NOCTO_1 = GroupName "noctovision improvement"+pattern WEAK_ARROW = GroupName "weak arrow"+pattern LIGHT_ATTENUATOR = GroupName "light attenuator"+pattern FIREPROOF_CLOTH = GroupName "fireproof cloth"+pattern RING_OF_OPPORTUNITY_SNIPER = GroupName "ring of sniper"+pattern ANY_ARROW = GroupName "arrow"+pattern STARTING_ARMOR = GroupName "starting armor"+pattern STARTING_WEAPON = GroupName "starting weapon"+pattern GEM = GroupName "gem"++-- * Content+ actors :: [ItemKind] actors =-  [warrior, adventurer, blacksmith, forester, scientist, clerk, hairdresser, lawyer, peddler, taxCollector, eye, fastEye, nose, elbow, armadillo, gilaMonster, komodoDragon, hyena, alligator, hornetSwarm, thornbush, geyser]+  [warrior, warrior2, warrior3, warrior4, warrior5, scout, ranger, escapist, ambusher, brawler, soldier, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, hyena, komodoDragon, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush]+  -- LH-specific+  ++ [geyserBoiling, geyserArsenic, geyserSulfur] -warrior,    adventurer, blacksmith, forester, scientist, clerk, hairdresser, lawyer, peddler, taxCollector, eye, fastEye, nose, elbow, armadillo, gilaMonster, komodoDragon, hyena, alligator, hornetSwarm, thornbush, geyser :: ItemKind+warrior,    warrior2, warrior3, warrior4, warrior5, scout, ranger, escapist, ambusher, brawler, soldier, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, hyena, komodoDragon, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush :: ItemKind+-- LH-specific+geyserBoiling, geyserArsenic, geyserSulfur :: ItemKind +-- Note that the actors that appear in the crawl scenario should+-- be generated with at most ordinary ammo. Otherwise, farming them+-- may be rational though boring endeavour. Any exceptions to that+-- should be well thought of. E.g., unique guaranteed items on bosses+-- are safe, just as restricted kinds of weak items.+ -- * Hunams +-- TODO: bring back S_EAR_3 when character progression permits hearing boosts.+humanOrgans :: [(GroupName ItemKind, CStore)]+humanOrgans = [ (S_FIST, COrgan), (S_FOOT, COrgan)+              , (S_EYE_6, COrgan), (S_EAR_6, COrgan)+              , (S_SAPIENT_BRAIN, COrgan) ] warrior = ItemKind-  { isymbol  = '@'-  , iname    = "warrior"  -- modified if in hero faction-  , ifreq    = [("hero", 100), ("civilian", 100)]-  , iflavour = zipPlain [BrBlack]  -- modified if in hero faction+  { isymbol  = toContentSymbol '@'+  , iname    = "adventurer"  -- modified if initial actors in hero faction+  , ifreq    = [(HERO, 100), (MOBILE, 1)]+  , iflavour = zipPlain [BrWhite]   , icount   = 1   , irarity  = [(1, 5)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 50, AddMaxCalm 60, AddSpeed 20-               , AddSight 3 ]  -- no via eyes, but feel, hearing, etc.+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 80  -- partially from clothes and first aid+               , AddSkill SkMaxCalm 70+               , AddSkill SkSpeed 20+               , AddSkill SkNocto 2+               , AddSkill SkWait 1  -- can lurk+               , AddSkill SkProject 2  -- can lob+               , AddSkill SkApply 2  -- can even apply periodic items+               , AddSkill SkOdor 1+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [("fist", COrgan), ("foot", COrgan), ("eye 4", COrgan)]+  , ikit     = humanOrgans+               ++ [(S_SANDSTONE_ROCK, CStash)]+  , idesc    = ""  -- "A hardened veteran of combat."   }-adventurer = warrior-  { iname    = "adventurer" }-blacksmith = warrior-  { iname    = "blacksmith" }-forester = warrior-  { iname    = "forester" }-scientist = warrior-  { iname    = "scientist" }+warrior2 = warrior+  { iname    = "warrior"+  , ikit     = humanOrgans+               ++ [(COMMON_ITEM, CStash)]+  -- , idesc    = ""+  }+warrior3 = warrior+  { iname    = "blacksmith"+  -- , idesc    = ""+  }+warrior4 = warrior+  { iname    = "forester"+  -- , idesc    = ""+  }+warrior5 = warrior+  { iname    = "scientist"+  -- , idesc    = ""+  } -clerk = warrior+scout = warrior+  { ifreq    = [(SCOUT_HERO, 100), (MOBILE, 1)]+  , ikit     = humanOrgans+               ++ [ (ADD_SIGHT, CEqp)+                  , (ARMOR_RANGED, CEqp)+                  , (ADD_NOCTO_1, CStash) ]+  -- , idesc    = ""+  }+ranger = warrior+  { ifreq    = [(RANGER_HERO, 100), (MOBILE, 1)]+  , ikit     = humanOrgans+               ++ [ (ARMOR_RANGED, CEqp)+                  , (WEAK_ARROW, CStash) ]+  -- , idesc    = ""+  }+escapist = warrior+  { ifreq    = [(ESCAPIST_HERO, 100), (MOBILE, 1)]+  , ikit     = humanOrgans+               ++ [ (ADD_SIGHT, CEqp)+                  , (STARTING_ARMOR, CEqp)+                  , (WEAK_ARROW, CStash)  -- mostly for probing+                  , (LIGHT_ATTENUATOR, CStash)+                  , (S_WOODEN_TORCH, CStash)+                  , (FIREPROOF_CLOTH, CStash) ]+  -- , idesc    = ""+  }+ambusher = warrior+  { ifreq    = [(AMBUSHER_HERO, 100), (MOBILE, 1)]+  , ikit     = humanOrgans  -- dark and numerous, so more kit without exploring+               ++ [ (RING_OF_OPPORTUNITY_SNIPER, CEqp)+                  , (ANY_ARROW, CStash), (ANY_ARROW, CStash)+                  , (WEAK_ARROW, CStash)+                  , (EXPLOSIVE, CStash)+                  , (LIGHT_ATTENUATOR, CEqp)+                  , (S_WOODEN_TORCH, CStash) ]+  -- , idesc    = ""+  }+brawler = warrior+  { ifreq    = [(BRAWLER_HERO, 100), (MOBILE, 1)]+  , ikit     = humanOrgans+               ++ [ (STARTING_WEAPON, CEqp)+                  , (ANY_POTION, CStash) ]+  -- , idesc    = ""+  }+soldier = brawler+  { ifreq    = [(SOLDIER_HERO, 100), (MOBILE, 1)]+  , ikit     = ikit brawler+               ++ [(EXPLOSIVE, CStash)]+  -- , idesc    = ""+  }++civilian = warrior   { iname    = "clerk"-  , ifreq    = [("civilian", 100)] }-hairdresser = clerk-  { iname    = "hairdresser" }-lawyer = clerk-  { iname    = "lawyer" }-peddler = clerk-  { iname    = "peddler" }-taxCollector = clerk-  { iname    = "tax collector" }+  , ifreq    = [(CIVILIAN, 100), (MOBILE, 1)]+  , iflavour = zipPlain [BrBlack]+  -- , idesc    = ""+  }+civilian2 = civilian+  { iname    = "hairdresser"+  -- , idesc    = ""+  }+civilian3 = civilian+  { iname    = "lawyer"+  -- , idesc    = ""+  }+civilian4 = civilian+  { iname    = "peddler"+  -- , idesc    = ""+  }+civilian5 = civilian+  { iname    = "tax collector"+  -- , idesc    = ""+  }  -- * Monsters +-- They have bright colours, because they are not natural.+ eye = ItemKind-  { isymbol  = 'e'+  { isymbol  = toContentSymbol 'e'   , iname    = "reducible eye"-  , ifreq    = [("monster", 100), ("horror", 100)]-  , iflavour = zipPlain [BrRed]+  , ifreq    = [ (MONSTER, 100), (MOBILE, 1)+               , (MOBILE_MONSTER, 100), (SCOUT_MONSTER, 10) ]+  , iflavour = zipFancy [BrRed]   , icount   = 1-  , irarity  = [(1, 10), (10, 6)]+  , irarity  = [(3, 0), (4, 10), (10, 8)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 20, AddMaxCalm 60, AddSpeed 20-               , AddSight 4 ]  -- can shoot for as long as lives+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 16, AddSkill SkMaxCalm 70+               , AddSkill SkSpeed 20, AddSkill SkNocto 2+               , AddSkill SkAggression 1+               , AddSkill SkProject 2  -- can lob+               , AddSkill SkApply 1  -- can use even cultural artifacts+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]   , idesc    = "Under your stare, it reduces to the bits that define its essence. Under introspection, the bits slow down and solidify into an arbitrary form again. It must be huge inside, for holographic principle to manifest so overtly."  -- holographic principle is an anachronism for XIX or most of XX century, but "the cosmological scale effects" is too weak-  , ikit     = [("lash", COrgan), ("pupil", COrgan)]+  , ikit     = [ (S_LASH, COrgan), (S_PUPIL, COrgan)  -- at least one non-timed+               , (S_SAPIENT_BRAIN, COrgan) ]  -- no hearing, it's all eyes   } fastEye = ItemKind-  { isymbol  = 'j'+  { isymbol  = toContentSymbol 'j'   , iname    = "injective jaw"-  , ifreq    = [("monster", 100), ("horror", 100)]-  , iflavour = zipPlain [BrBlue]+  , ifreq    = [ (MONSTER, 100), (MOBILE, 1)+               , (MOBILE_MONSTER, 100), (SCOUT_MONSTER, 60) ]+  , iflavour = zipFancy [BrBlue]   , icount   = 1-  , irarity  = [(10, 5)]+  , irarity  = [(3, 0), (4, 6), (10, 12)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 6, AddMaxCalm 60, AddSpeed 30-               , AddSight 7 ]  -- can shoot for as long as lives+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 5, AddSkill SkMaxCalm 70+               , AddSkill SkSpeed 30, AddSkill SkNocto 2+               , AddSkill SkAggression 1+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]   , idesc    = "Hungers but never eats. Bites but never swallows. Burrows its own image through, but never carries anything back."  -- rather weak: not about injective objects, but puny, concrete, injective functions  --- where's the madness in that?-  , ikit     = [ ("tooth", COrgan), ("speed gland 10", COrgan)-               , ("lip", COrgan), ("lip", COrgan) ]+  , ikit     = [ (S_TOOTH, COrgan), (S_LIP, COrgan)  -- at least one non-timed+               , (S_SPEED_GLAND_10, COrgan)+               , (S_VISION_6, COrgan), (S_EAR_3, COrgan)+               , (S_SAPIENT_BRAIN, COrgan) ]   }-nose = ItemKind-  { isymbol  = 'n'+nose = ItemKind  -- depends solely on smell+  { isymbol  = toContentSymbol 'n'   , iname    = "point-free nose"-  , ifreq    = [("monster", 100), ("horror", 100)]-  , iflavour = zipPlain [BrGreen]+  , ifreq    = [(MONSTER, 100), (MOBILE, 1), (MOBILE_MONSTER, 100)]+  , iflavour = zipFancy [BrGreen]   , icount   = 1-  , irarity  = [(1, 6), (10, 4)]+  , irarity  = [(3, 0), (4, 5), (10, 7)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 40, AddMaxCalm 30, AddSpeed 18-               , AddSmell 3 ]  -- depends solely on smell+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 30, AddSkill SkMaxCalm 30+               , AddSkill SkSpeed 18, AddSkill SkNocto 2+               , AddSkill SkAggression 1+               , AddSkill SkProject (-1)  -- can't project+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]   , idesc    = "No mouth, yet it devours everything around, constantly sniffing itself inward; pure movement structure, no constant point to focus one's maddened gaze on."-  , ikit     = [("nose tip", COrgan), ("lip", COrgan)]+  , ikit     = [ (S_TIP, COrgan), (S_LIP, COrgan)  -- at least one non-timed+               , (S_NOSTRIL, COrgan)+               , (S_SAPIENT_BRAIN, COrgan) ]  -- no sight nor hearing   } elbow = ItemKind-  { isymbol  = 'e'+  { isymbol  = toContentSymbol 'e'   , iname    = "commutative elbow"-  , ifreq    = [("monster", 100), ("horror", 100)]-  , iflavour = zipPlain [BrMagenta]+  , ifreq    = [ (MONSTER, 100), (MOBILE, 1)+               , (MOBILE_MONSTER, 100), (SCOUT_MONSTER, 30) ]+  , iflavour = zipFancy [BrMagenta]   , icount   = 1-  , irarity  = [(6, 1), (10, 5)]+  , irarity  = [(3, 0), (4, 1), (10, 12)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 10, AddMaxCalm 80, AddSpeed 26-               , AddSkills $ EM.singleton AbMelee (-1)-               , AddSight 15 ]  -- can shoot for as long as lives+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 8, AddSkill SkMaxCalm 80+               , AddSkill SkSpeed 20, AddSkill SkNocto 2+               , AddSkill SkProject 2  -- can lob+               , AddSkill SkApply 1  -- can even use cultural artifacts+               , AddSkill SkMelee (-1)+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]   , idesc    = "An arm strung like a bow. A few edges, but none keen enough. A few points, but none piercing. Deadly objects zip out of the void."-  , ikit     = [ ("speed gland 4", COrgan), ("armored skin", COrgan)-               , ("any arrow", CInv), ("any arrow", CInv)-               , ("any arrow", CInv), ("any arrow", CInv) ]+  , ikit     = [ (S_SPEED_GLAND_5, COrgan), (S_BARK, COrgan)+               , (S_VISION_12, COrgan), (S_EAR_8, COrgan)+                   -- too powerful to get stronger sight+               , (S_SAPIENT_BRAIN, COrgan)+               , (ANY_ARROW, CStash), (ANY_ARROW, CStash)+               , (WEAK_ARROW, CStash), (WEAK_ARROW, CStash) ]   }+torsor = ItemKind+  { isymbol  = toContentSymbol 'T'+  , iname    = "The Forgetful Torsor"+  , ifreq    = [(MONSTER, 100), (MOBILE, 1)]+  , iflavour = zipFancy [BrCyan]+  , icount   = 1+  , irarity  = [(9, 0), (10, 1000)]  -- unique+  , iverbHit = "thud"+  , iweight  = 80000+  , idamage  = 0+  , iaspects = [ SetFlag Unique+               , AddSkill SkMaxHP 300, AddSkill SkMaxCalm 100+               , AddSkill SkSpeed 15, AddSkill SkNocto 2+               , AddSkill SkAggression 3+               , AddSkill SkProject 2  -- can lob+               , AddSkill SkApply 1  -- can even use cultural artifacts+               , AddSkill SkAlter (-1)  -- can't exit the gated level; a boss,+                                        -- but can dig rubble, ice+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "A principal homogeneous manifold, that acts freely and with enormous force, but whose stabilizers are trivial, making it rather helpless without a support group."+  , ikit     = [ (S_RIGHT_TORSION, COrgan), (S_LEFT_TORSION, COrgan)+               , (S_PUPIL, COrgan)+               , (S_TENTACLE, COrgan)  -- low timeout, so rarely a stall+               , (S_EAR_8, COrgan)+               , (S_SAPIENT_BRAIN, COrgan)+               , (GEM, CStash), (GEM, CStash)+               , (GEM, CStash), (GEM, CStash) ]+  } -- "ground x" --- for immovable monster that can only tele or prob travel--- forgetful -- pullback -- skeletal  -- * Animals +-- They need rather strong melee, because they don't use items.+-- They have dull colors, except for yellow, because there is no dull variant.++goldenJackal = ItemKind  -- basically a much smaller, slower and nosy hyena+  { isymbol  = toContentSymbol 'j'+  , iname    = "golden jackal"+  , ifreq    = [ (ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)+               , (SCAVENGER, 50) ]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(1, 4), (10, 2)]+  , iverbHit = "thud"+  , iweight  = 13000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 15, AddSkill SkMaxCalm 70+               , AddSkill SkSpeed 24, AddSkill SkNocto 2+               , AddSkill SkAggression 2  -- scout+               , AddSkill SkDisplace 1  -- scout+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "An opportunistic predator, feeding on carrion and the weak."+  , ikit     = [ (S_SMALL_JAW, COrgan)+               , (S_EYE_6, COrgan), (S_NOSTRIL, COrgan), (S_EAR_8, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]+  }+griffonVulture = ItemKind  -- keep it boring and weak, because it summons+  { isymbol  = toContentSymbol 'v'+  , iname    = "griffon vulture"+  , ifreq    = [ (ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)+               , (SCAVENGER, 30) ]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(1, 3), (10, 3)]+  , iverbHit = "thud"+  , iweight  = 13000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 15, AddSkill SkMaxCalm 80+                   -- enough Calm to summon twice only if not attacked at all;+                   -- loses a lot of sight after summoning+               , AddSkill SkSpeed 22, AddSkill SkNocto 2+               , AddSkill SkAlter (-2)  -- can't use hard stairs nor doors+               , AddSkill SkFlying 10  -- flies slowly, but far+               , SetFlag Durable ]+      -- Animals don't have leader, usually, so even if only one on level,+      -- it pays the communication overhead, so the speed is higher to get+      -- them on par with human leaders moving solo.+  , ieffects = []+  , idesc    = "It soars high above, searching for vulnerable prey."+  , ikit     = [ (S_SCREECHING_BEAK, COrgan)  -- in reality it grunts and hisses+               , (S_SMALL_CLAW, COrgan)+               , (S_EYE_8, COrgan), (S_EAR_8, COrgan)+                   -- can't shoot, so strong sight is OK+               , (S_ANIMAL_BRAIN, COrgan) ]+  }+skunk = ItemKind+  { isymbol  = toContentSymbol 's'+  , iname    = "hog-nosed skunk"+  , ifreq    = [(ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)]+  , iflavour = zipPlain [White]+  , icount   = 1+  , irarity  = [(1, 8), (5, 1)]+  , iverbHit = "thud"+  , iweight  = 4000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 13, AddSkill SkMaxCalm 30+               , AddSkill SkSpeed 22, AddSkill SkNocto 2+               , AddSkill SkAlter (-2)  -- can't use hard stairs nor doors+               , AddSkill SkOdor 5  -- and no smell skill, to let it leave smell+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "Its only defence is the terrible stench."+  , ikit     = [ (S_SCENT_GLAND, COrgan)+               , (S_SMALL_CLAW, COrgan), (S_SNOUT, COrgan)+               , (S_EYE_3, COrgan), (S_EAR_6, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]+  } armadillo = ItemKind-  { isymbol  = 'a'+  { isymbol  = toContentSymbol 'a'   , iname    = "giant armadillo"-  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , ifreq    = [(ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)]   , iflavour = zipPlain [Brown]   , icount   = 1-  , irarity  = [(1, 5)]+  , irarity  = [(1, 7)]   , iverbHit = "thud"-  , iweight  = 80000-  , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18-               , AddSkills $ EM.singleton AbAlter (-1)-               , AddSight 3 ]+  , iweight  = 54000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 25, AddSkill SkMaxCalm 30+               , AddSkill SkSpeed 20, AddSkill SkNocto 2+               , AddSkill SkHurtMelee (-70)  -- quite harmless rolled in a ball+               , AddSkill SkAlter (-2)  -- can't use hard stairs nor doors+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [ ("claw", COrgan), ("snout", COrgan), ("armored skin", COrgan)-               , ("nostril", COrgan) ]+  , idesc    = "When threatened, it rolls into a ball."+  , ikit     = [ (S_HOOKED_CLAW, COrgan), (S_SNOUT, COrgan)+               , (S_ARMORED_SKIN, COrgan), (S_ARMORED_SKIN, COrgan)+               , (S_EYE_3, COrgan), (S_NOSTRIL, COrgan), (S_EAR_6, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]   } gilaMonster = ItemKind-  { isymbol  = 'g'+  { isymbol  = toContentSymbol 'g'   , iname    = "Gila monster"-  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , ifreq    = [(ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)]   , iflavour = zipPlain [Magenta]   , icount   = 1-  , irarity  = [(2, 5), (10, 3)]+  , irarity  = [(2, 5), (10, 2)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 15, AddMaxCalm 60, AddSpeed 15-               , AddSkills $ EM.singleton AbAlter (-1)-               , AddSight 3 ]+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 15, AddSkill SkMaxCalm 50+               , AddSkill SkSpeed 18, AddSkill SkNocto 2+               , AddSkill SkAlter (-2)  -- can't use hard stairs nor doors+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [ ("venom tooth", COrgan), ("small claw", COrgan)-               , ("eye 4", COrgan), ("nostril", COrgan) ]+  , idesc    = "Numbing venom ensures that even the fastest prey has no escape."+  , ikit     = [ (S_VENOM_TOOTH, COrgan), (S_SMALL_CLAW, COrgan)+               , (S_EYE_3, COrgan), (S_NOSTRIL, COrgan), (S_EAR_6, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]   }-komodoDragon = ItemKind  -- bad hearing-  { isymbol  = 'k'-  , iname    = "Komodo dragon"-  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]-  , iflavour = zipPlain [Blue]+rattlesnake = ItemKind+  { isymbol  = toContentSymbol 's'+  , iname    = "rattlesnake"+  , ifreq    = [(ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)]+  , iflavour = zipPlain [Brown]   , icount   = 1-  , irarity  = [(5, 5), (10, 7)]+  , irarity  = [(5, 1), (10, 7), (20, 10)]  -- common among late spawns   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 40, AddMaxCalm 60, AddSpeed 18-               , AddSight 3 ]+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 28, AddSkill SkMaxCalm 60+               , AddSkill SkSpeed 16, AddSkill SkNocto 2+               , AddSkill SkAggression 2  -- often discharged. so flees anyway+               , AddSkill SkAlter (-2)  -- can't use hard stairs nor doors+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [ ("large tail", COrgan), ("jaw", COrgan), ("small claw", COrgan)-               , ("speed gland 4", COrgan), ("armored skin", COrgan)-               , ("eye 2", COrgan), ("nostril", COrgan) ]+  , idesc    = "Beware its rattle - it serves as a warning of an agonising death."+  , ikit     = [ (S_VENOM_FANG, COrgan)  -- when discharged, it's weaponless+               , (S_RATLLE, COrgan)+               , (S_EYE_3, COrgan), (S_NOSTRIL, COrgan), (S_EAR_6, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]   } hyena = ItemKind-  { isymbol  = 'h'+  { isymbol  = toContentSymbol 'h'   , iname    = "spotted hyena"-  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]-  , iflavour = zipPlain [Red]+  , ifreq    = [ (ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)+               , (SCAVENGER, 20) ]+  , iflavour = zipPlain [BrYellow]   , icount   = 1-  , irarity  = [(4, 6), (10, 6)]+  , irarity  = [(4, 1), (10, 5), (20, 10)]+      -- gets summoned often, so low base rarity, except among late spawns   , iverbHit = "thud"+  , iweight  = 60000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 23, AddSkill SkMaxCalm 70+               , AddSkill SkSpeed 32, AddSkill SkNocto 2+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "Skulking in the shadows, waiting for easy prey."+  , ikit     = [ (S_JAW, COrgan), (S_SMALL_CLAW, COrgan)+               , (S_EYE_6, COrgan), (S_NOSTRIL, COrgan), (S_EAR_8, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]+  }+komodoDragon = ItemKind+  { isymbol  = toContentSymbol 'k'+  , iname    = "Komodo dragon"+  , ifreq    = [(ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)]+  , iflavour = zipPlain [BrRed]  -- speedy, so bright red+  , icount   = 1+  , irarity  = [(9, 0), (10, 11), (20, 20)]+  , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 30, AddMaxCalm 60, AddSpeed 35-               , AddSight 3 ]+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 40, AddSkill SkMaxCalm 60  -- regens+               , AddSkill SkSpeed 17, AddSkill SkNocto 2+               , AddSkill SkHurtMelee 60  -- great fighter with low cooldowns+               , AddSkill SkAggression 1  -- match the description+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [("jaw", COrgan), ("eye 4", COrgan), ("nostril", COrgan)]+  , idesc    = "Larger and more aggressive than any other lizard, but as easily recovering from wounds as its lesser cousins."+  , ikit     = [ (S_LARGE_TAIL, COrgan), (S_JAW, COrgan)+               , (S_LIP, COrgan), (S_FOOT, COrgan)+               , (S_SPEED_GLAND_5, COrgan), (S_ARMORED_SKIN, COrgan)+               , (S_EYE_3, COrgan), (S_NOSTRIL, COrgan), (S_EAR_3, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]   }-alligator = ItemKind-  { isymbol  = 'a'+alligator = ItemKind  -- late, slow, deadly semi-tank with some armor;+                      -- too deadly to get more HP; bombs the only recourse+  { isymbol  = toContentSymbol 'a'   , iname    = "alligator"-  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , ifreq    = [(ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)]   , iflavour = zipPlain [Blue]   , icount   = 1-  , irarity  = [(10, 8)]+  , irarity  = [(9, 0), (10, 12), (20, 10), (40, 40)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 30, AddMaxCalm 60, AddSpeed 17-               , AddArmorMelee 30, AddArmorRanged 30-               , AddSight 3 ]+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 55, AddSkill SkMaxCalm 70+               , AddSkill SkSpeed 18, AddSkill SkNocto 2+               , AddSkill SkSwimming 100  -- swims better than walks+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [ ("large jaw", COrgan), ("large tail", COrgan), ("claw", COrgan)-               , ("armored skin", COrgan), ("eye 4", COrgan) ]+  , idesc    = "An armored predator from the dawn of time. You better not get within its reach."+  , ikit     = [ (S_HUGE_TAIL, COrgan)  -- the special trick, breaking frontline+               , (S_LARGE_JAW, COrgan)+               , (S_SMALL_CLAW, COrgan)+               , (S_ARMORED_SKIN, COrgan)+               , (S_EYE_6, COrgan), (S_EAR_8, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]   }+rhinoceros = ItemKind+  { isymbol  = toContentSymbol 'R'+  , iname    = "The Maddened Rhinoceros"+  , ifreq    = [(ANIMAL, 100), (MOBILE, 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(2, 0), (3, 1000), (4, 0)]  -- an early unique+  , iverbHit = "thud"+  , iweight  = 80000+  , idamage  = 0+  , iaspects = [ SetFlag Unique+               , AddSkill SkMaxHP 90, AddSkill SkMaxCalm 60+               , AddSkill SkSpeed 27, AddSkill SkNocto 2+               , AddSkill SkAggression 2+               , AddSkill SkAlter (-1)  -- can't use hard stairs nor dig;+                                        -- a weak miniboss+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "The last of its kind. Blind with rage. Charges at deadly speed."+  , ikit     = [ (S_RHINO_HORN, COrgan), (S_SNOUT, COrgan)+               , (S_ARMORED_SKIN, COrgan)+               , (S_EYE_3, COrgan), (S_EAR_8, COrgan)+               , (S_ANIMAL_BRAIN, COrgan) ]+  }  -- * Non-animal animals -hornetSwarm = ItemKind-  { isymbol  = 'h'+beeSwarm = ItemKind+  { isymbol  = toContentSymbol 'b'+  , iname    = "bee swarm"+  , ifreq    = [(ANIMAL, 100), (INSECT, 50), (MOBILE, 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(1, 3), (10, 4)]+  , iverbHit = "buzz"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 10, AddSkill SkMaxCalm 60+               , AddSkill SkSpeed 30, AddSkill SkNocto 2  -- armor in sting+               , AddSkill SkAlter (-2)  -- can't use hard stairs nor doors+               , AddSkill SkWait (-2)  -- can't brace, sleep and lurk+               , AddSkill SkFlying 10  -- flies slowly, but far+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "Every bee would die for the queen."+  , ikit     = [ (S_BEE_STING, COrgan)  -- weaponless when it's used up+               , (S_VISION_6, COrgan), (S_EAR_6, COrgan)+               , (S_INSECT_MORTALITY, COrgan), (S_ANIMAL_BRAIN, COrgan) ]+  }+hornetSwarm = ItemKind  -- kind of tank with armor, but short-lived+  { isymbol  = toContentSymbol 'h'   , iname    = "hornet swarm"-  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , ifreq    = [(ANIMAL, 100), (INSECT, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)]   , iflavour = zipPlain [Magenta]   , icount   = 1-  , irarity  = [(5, 1), (10, 5)]-  , iverbHit = "thud"+  , irarity  = [(5, 1), (10, 4), (20, 10)]+      -- should be many, because die after a time+  , iverbHit = "buzz"   , iweight  = 1000-  , iaspects = [ AddMaxHP 5, AddMaxCalm 60, AddSpeed 30, AddSight 2-               , AddSkills $ EM.singleton AbAlter (-1)-               , AddArmorMelee 90, AddArmorRanged 90 ]+  , idamage  = 0+  , iaspects = [ AddSkill SkArmorMelee 80, AddSkill SkArmorRanged 40+               , AddSkill SkHurtMelee 50+               , AddSkill SkMaxHP 10, AddSkill SkMaxCalm 70+               , AddSkill SkSpeed 30, AddSkill SkNocto 2+               , AddSkill SkAlter (-2)  -- can't use hard stairs nor doors+               , AddSkill SkWait (-2)  -- can't brace, sleep and lurk+               , AddSkill SkFlying 10  -- flies slowly, but far+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [("sting", COrgan)]+  , idesc    = "A vicious cloud of stings and hate."+  , ikit     = [ (S_STING, COrgan)  -- when on cooldown, it's weaponless+               , (S_VISION_6, COrgan), (S_EAR_6, COrgan)+               , (S_INSECT_MORTALITY, COrgan), (S_ANIMAL_BRAIN, COrgan) ]   }-thornbush = ItemKind-  { isymbol  = 'b'+thornbush = ItemKind  -- the wimpiest kind of early tank+  { isymbol  = toContentSymbol 't'   , iname    = "thornbush"-  , ifreq    = [("animal", 100)]+  , ifreq    = [(ANIMAL, 20), (IMMOBILE_ANIMAL, 20)]   , iflavour = zipPlain [Brown]   , icount   = 1-  , irarity  = [(3, 2), (10, 1)]-  , iverbHit = "thud"+  , irarity  = [(1, 13)]+  , iverbHit = "scrape"   , iweight  = 80000-  , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20-               , AddSkills-                 $ EM.fromDistinctAscList (zip [minBound..maxBound] [-1, -1..])-                   `addSkills` EM.fromList (zip [AbWait, AbMelee] [1, 1..])-               , AddArmorMelee 50, AddArmorRanged 50 ]+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 30, AddSkill SkMaxCalm 999+               , AddSkill SkSpeed 22, AddSkill SkNocto 2+               , AddSkill SkWait 1, AddSkill SkMelee 1  -- no brain+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [("thorn", COrgan)]+  , idesc    = "Each branch bears long, curved thorns."+  , ikit     = [ (S_THORN, COrgan)  -- after all run out, it's weaponless+               , (S_BARK, COrgan) ]   }-geyser = ItemKind-  { isymbol  = 'g'+geyserBoiling = ItemKind+  { isymbol  = toContentSymbol 'g'   , iname    = "geyser"-  , ifreq    = [("animal", 100)]-  , iflavour = zipPlain [White]+  , ifreq    = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 30), (GEOPHENOMENON, 1)]+  , iflavour = zipPlain [Blue]   , icount   = 1-  , irarity  = [(5, 2), (10, 1)]+  , irarity  = [(1, 10), (10, 6)]   , iverbHit = "thud"   , iweight  = 80000-  , iaspects = [ AddMaxHP 100, AddMaxCalm 999, AddSpeed 5-               , AddSkills-                 $ EM.fromDistinctAscList (zip [minBound..maxBound] [-1, -1..])-                   `addSkills` EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ]+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 10, AddSkill SkMaxCalm 999+               , AddSkill SkSpeed 11, AddSkill SkNocto 2+               , AddSkill SkWait 1, AddSkill SkMelee 1  -- no brain+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]-  , idesc    = ""-  , ikit     = [("vent", COrgan), ("fissure", COrgan)]+  , idesc    = "A jet of acidic water, hot enough to melt flesh."+  , ikit     = [(S_BOILING_VENT, COrgan), (S_BOILING_FISSURE, COrgan)]+  }+geyserArsenic = ItemKind+  { isymbol  = toContentSymbol 'g'+  , iname    = "arsenic geyser"+  , ifreq    = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 40), (GEOPHENOMENON, 1)]+  , iflavour = zipPlain [Cyan]+  , icount   = 1+  , irarity  = [(1, 10), (10, 6)]+  , iverbHit = "thud"+  , iweight  = 80000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 20, AddSkill SkMaxCalm 999+               , AddSkill SkSpeed 22, AddSkill SkNocto 2, AddSkill SkShine 3+               , AddSkill SkWait 1, AddSkill SkMelee 1  -- no brain+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "The sharp scent betrays the poison within the spray."+  , ikit     = [(S_ARSENIC_VENT, COrgan), (S_ARSENIC_FISSURE, COrgan)]+  }+geyserSulfur = ItemKind+  { isymbol  = toContentSymbol 'g'+  , iname    = "sulfur geyser"+  , ifreq    = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 120), (GEOPHENOMENON, 1)]+  , iflavour = zipPlain [BrYellow]  -- exception, animal with bright color+  , icount   = 1+  , irarity  = [(1, 10), (10, 6)]+  , iverbHit = "thud"+  , iweight  = 80000+  , idamage  = 0+  , iaspects = [ AddSkill SkMaxHP 20, AddSkill SkMaxCalm 999+               , AddSkill SkSpeed 22, AddSkill SkNocto 2, AddSkill SkShine 3+               , AddSkill SkWait 1, AddSkill SkMelee 1  -- no brain+               , SetFlag Durable ]+  , ieffects = []+  , idesc    = "The pool boils and bubbles, stinking of rotten eggs. Despite the smell, these waters purify and strengthen."+  , ikit     = [(S_SULFUR_VENT, COrgan), (S_SULFUR_FISSURE, COrgan)]   }
+ GameDefinition/Content/ItemKindBlast.hs view
@@ -0,0 +1,960 @@+-- | Blast definitions.+module Content.ItemKindBlast+  ( -- * Group name patterns+    pattern S_FIRECRACKER, pattern S_VIOLENT_FRAGMENTATION, pattern S_FRAGMENTATION, pattern S_FOCUSED_FRAGMENTATION, pattern S_VIOLENT_CONCUSSION, pattern S_CONCUSSION, pattern S_FOCUSED_CONCUSSION, pattern S_VIOLENT_FLASH, pattern S_FOCUSED_FLASH, pattern S_GLASS_HAIL, pattern S_FOCUSED_GLASS_HAIL, pattern S_PHEROMONE, pattern S_CALMING_MIST, pattern S_DISTRESSING_ODOR, pattern S_HEALING_MIST, pattern S_HEALING_MIST_2, pattern S_WOUNDING_MIST, pattern S_DISTORTION, pattern S_SMOKE, pattern S_BOILING_WATER, pattern S_GLUE, pattern S_WASTE, pattern S_ANTI_SLOW_MIST, pattern S_ANTIDOTE_MIST, pattern S_SLEEP_MIST, pattern S_DENSE_SHOWER, pattern S_SPARSE_SHOWER, pattern S_MELEE_PROTECTIVE_BALM, pattern S_RANGE_PROTECTIVE_BALM, pattern S_DEFENSELESSNESS_RUNOUT, pattern S_RESOLUTION_DUST, pattern S_HASTE_SPRAY, pattern S_VIOLENT_SLOWNESS_MIST, pattern S_SLOWNESS_MIST, pattern S_FOCUSED_SLOWNESS_MIST, pattern S_EYE_DROP, pattern S_IRON_FILING, pattern S_SMELLY_DROPLET, pattern S_EYE_SHINE, pattern S_WHISKEY_SPRAY, pattern S_YOUTH_SPRINKLE, pattern S_POISON_CLOUD, pattern S_PING_PLASH, pattern S_VIOLENT_BURNING_OIL_2, pattern S_VIOLENT_BURNING_OIL_3, pattern S_VIOLENT_BURNING_OIL_4, pattern S_BURNING_OIL_2, pattern S_BURNING_OIL_3, pattern S_BURNING_OIL_4, pattern S_FOCUSED_BURNING_OIL_2, pattern S_FOCUSED_BURNING_OIL_3, pattern S_FOCUSED_BURNING_OIL_4+  , blastNoStatOf, blastBonusStatOf+  , pattern ARMOR_MISC+  , blastsGNSingleton, blastsGN+  , -- * Content+    blasts+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Core.Dice+import Game.LambdaHack.Definition.Ability+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal+import Game.LambdaHack.Definition.Flavour++import Content.ItemKindTemporary++-- * Group name patterns++blastsGNSingleton :: [GroupName ItemKind]+blastsGNSingleton =+       [S_FIRECRACKER, S_VIOLENT_FRAGMENTATION, S_FRAGMENTATION, S_FOCUSED_FRAGMENTATION, S_VIOLENT_CONCUSSION, S_CONCUSSION, S_FOCUSED_CONCUSSION, S_VIOLENT_FLASH, S_FOCUSED_FLASH, S_GLASS_HAIL, S_FOCUSED_GLASS_HAIL, S_PHEROMONE, S_CALMING_MIST, S_DISTRESSING_ODOR, S_HEALING_MIST, S_HEALING_MIST_2, S_WOUNDING_MIST, S_DISTORTION, S_SMOKE, S_BOILING_WATER, S_GLUE, S_WASTE, S_ANTI_SLOW_MIST, S_ANTIDOTE_MIST, S_SLEEP_MIST, S_DENSE_SHOWER, S_SPARSE_SHOWER, S_MELEE_PROTECTIVE_BALM, S_RANGE_PROTECTIVE_BALM, S_DEFENSELESSNESS_RUNOUT, S_RESOLUTION_DUST, S_HASTE_SPRAY, S_VIOLENT_SLOWNESS_MIST, S_SLOWNESS_MIST, S_FOCUSED_SLOWNESS_MIST, S_EYE_DROP, S_IRON_FILING, S_SMELLY_DROPLET, S_EYE_SHINE, S_WHISKEY_SPRAY, S_YOUTH_SPRINKLE, S_POISON_CLOUD, S_PING_PLASH, S_VIOLENT_BURNING_OIL_2, S_VIOLENT_BURNING_OIL_3, S_VIOLENT_BURNING_OIL_4, S_BURNING_OIL_2, S_BURNING_OIL_3, S_BURNING_OIL_4, S_FOCUSED_BURNING_OIL_2, S_FOCUSED_BURNING_OIL_3, S_FOCUSED_BURNING_OIL_4]+  ++ map firecrackerAt [1..4]+  ++ map blastNoStatOf noStatGN+  ++ map blastBonusStatOf bonusStatGN++pattern S_FIRECRACKER, S_VIOLENT_FRAGMENTATION, S_FRAGMENTATION, S_FOCUSED_FRAGMENTATION, S_VIOLENT_CONCUSSION, S_CONCUSSION, S_FOCUSED_CONCUSSION, S_VIOLENT_FLASH, S_FOCUSED_FLASH, S_GLASS_HAIL, S_FOCUSED_GLASS_HAIL, S_PHEROMONE, S_CALMING_MIST, S_DISTRESSING_ODOR, S_HEALING_MIST, S_HEALING_MIST_2, S_WOUNDING_MIST, S_DISTORTION, S_SMOKE, S_BOILING_WATER, S_GLUE, S_WASTE, S_ANTI_SLOW_MIST, S_ANTIDOTE_MIST, S_SLEEP_MIST, S_DENSE_SHOWER, S_SPARSE_SHOWER, S_MELEE_PROTECTIVE_BALM, S_RANGE_PROTECTIVE_BALM, S_DEFENSELESSNESS_RUNOUT, S_RESOLUTION_DUST, S_HASTE_SPRAY, S_VIOLENT_SLOWNESS_MIST, S_SLOWNESS_MIST, S_FOCUSED_SLOWNESS_MIST, S_EYE_DROP, S_IRON_FILING, S_SMELLY_DROPLET, S_EYE_SHINE, S_WHISKEY_SPRAY, S_YOUTH_SPRINKLE, S_POISON_CLOUD, S_PING_PLASH, S_VIOLENT_BURNING_OIL_2, S_VIOLENT_BURNING_OIL_3, S_VIOLENT_BURNING_OIL_4, S_BURNING_OIL_2, S_BURNING_OIL_3, S_BURNING_OIL_4, S_FOCUSED_BURNING_OIL_2, S_FOCUSED_BURNING_OIL_3, S_FOCUSED_BURNING_OIL_4 :: GroupName ItemKind++blastsGN :: [GroupName ItemKind]+blastsGN =+       [ARMOR_MISC]++pattern ARMOR_MISC :: GroupName ItemKind++pattern S_FIRECRACKER = GroupName "firecracker"+pattern S_VIOLENT_FRAGMENTATION = GroupName "violent fragmentation"+pattern S_FRAGMENTATION = GroupName "fragmentation"+pattern S_FOCUSED_FRAGMENTATION = GroupName "focused fragmentation"+pattern S_VIOLENT_CONCUSSION = GroupName "violent concussion"+pattern S_CONCUSSION = GroupName "concussion"+pattern S_FOCUSED_CONCUSSION = GroupName "focused concussion"+pattern S_VIOLENT_FLASH = GroupName "violent flash"+pattern S_FOCUSED_FLASH = GroupName "focused flash"+pattern S_GLASS_HAIL = GroupName "glass hail"+pattern S_FOCUSED_GLASS_HAIL = GroupName "focused glass hail"+pattern S_PHEROMONE = GroupName "pheromone"+pattern S_CALMING_MIST = GroupName "calming mist"+pattern S_DISTRESSING_ODOR = GroupName "distressing odor"+pattern S_HEALING_MIST = GroupName "healing mist"+pattern S_HEALING_MIST_2 = GroupName "strong healing mist"+pattern S_WOUNDING_MIST = GroupName "wounding mist"+pattern S_DISTORTION = GroupName "distortion"+pattern S_SMOKE = GroupName "smoke"+pattern S_BOILING_WATER = GroupName "boiling water"+pattern S_GLUE = GroupName "glue"+pattern S_WASTE = GroupName "waste"+pattern S_ANTI_SLOW_MIST = GroupName "anti-slow mist"+pattern S_ANTIDOTE_MIST = GroupName "antidote mist"+pattern S_SLEEP_MIST = GroupName "sleep mist"+pattern S_DENSE_SHOWER = GroupName "dense shower"+pattern S_SPARSE_SHOWER = GroupName "sparse shower"+pattern S_MELEE_PROTECTIVE_BALM = GroupName "melee protective balm"+pattern S_RANGE_PROTECTIVE_BALM = GroupName "ranged protective balm"+pattern S_DEFENSELESSNESS_RUNOUT = GroupName "PhD defense question"+pattern S_RESOLUTION_DUST = GroupName "resolution dust"+pattern S_HASTE_SPRAY = GroupName "haste spray"+pattern S_VIOLENT_SLOWNESS_MIST = GroupName "violent nitrogen mist"+pattern S_SLOWNESS_MIST = GroupName "nitrogen mist"+pattern S_FOCUSED_SLOWNESS_MIST = GroupName "focused nitrogen mist"+pattern S_EYE_DROP = GroupName "eye drop"+pattern S_IRON_FILING = GroupName "iron filing"+pattern S_SMELLY_DROPLET = GroupName "smelly droplet"+pattern S_EYE_SHINE = GroupName "eye shine"+pattern S_WHISKEY_SPRAY = GroupName "whiskey spray"+pattern S_YOUTH_SPRINKLE = GroupName "youth sprinkle"+pattern S_POISON_CLOUD = GroupName "poison cloud"+pattern S_PING_PLASH = GroupName "ping and flash"+pattern S_VIOLENT_BURNING_OIL_2 = GroupName "violent burning oil 2"+pattern S_VIOLENT_BURNING_OIL_3 = GroupName "violent burning oil 3"+pattern S_VIOLENT_BURNING_OIL_4 = GroupName "violent burning oil 4"+pattern S_BURNING_OIL_2 = GroupName "burning oil 2"+pattern S_BURNING_OIL_3 = GroupName "burning oil 3"+pattern S_BURNING_OIL_4 = GroupName "burning oil 4"+pattern S_FOCUSED_BURNING_OIL_2 = GroupName "focused burning oil 2"+pattern S_FOCUSED_BURNING_OIL_3 = GroupName "focused burning oil 3"+pattern S_FOCUSED_BURNING_OIL_4 = GroupName "focused burning oil 4"++firecrackerAt :: Int -> GroupName ItemKind+firecrackerAt n = GroupName $ "firecracker" <+> tshow n++blastNoStatOf :: GroupName ItemKind -> GroupName ItemKind+blastNoStatOf grp = GroupName $ fromGroupName grp <+> "mist"++blastBonusStatOf :: GroupName ItemKind -> GroupName ItemKind+blastBonusStatOf grp = GroupName $ fromGroupName grp <+> "dew"++pattern ARMOR_MISC = GroupName "miscellaneous armor"++-- * Content++blasts :: [ItemKind]+blasts =+  [spreadBurningOil2, spreadBurningOil3, spreadBurningOil4, spreadBurningOil82, spreadBurningOil83, spreadBurningOil84, focusedBurningOil2, focusedBurningOil3, focusedBurningOil4, firecracker1, firecracker2, firecracker3, firecracker4, firecracker5, spreadFragmentation, spreadFragmentation8, focusedFragmentation, spreadConcussion, spreadConcussion8, focusedConcussion, spreadFlash, spreadFlash8, focusedFlash, singleSpark, glassPiece, focusedGlass, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, smoke, boilingWater, glue, waste, mistAntiSlow, mistAntidote, mistSleep, denseShower, sparseShower, protectingBalmMelee, protectingBalmRanged, defenselessnessRunout, resolutionDust, hasteSpray, spreadNitrogen, spreadNitrogen8, focusedNitrogen, eyeDrop, ironFiling, smellyDroplet, eyeShine, whiskeySpray, youthSprinkle, poisonCloud, pingFlash, blastNoSkMove, blastNoSkMelee, blastNoSkDisplace, blastNoSkAlter, blastNoSkWait, blastNoSkMoveItem, blastNoSkProject, blastNoSkApply, blastBonusSkMove, blastBonusSkMelee, blastBonusSkDisplace, blastBonusSkAlter, blastBonusSkWait, blastBonusSkMoveItem, blastBonusSkProject, blastBonusSkApply]++spreadBurningOil2,    spreadBurningOil3, spreadBurningOil4, spreadBurningOil82, spreadBurningOil83, spreadBurningOil84, focusedBurningOil2, focusedBurningOil3, focusedBurningOil4, firecracker1, firecracker2, firecracker3, firecracker4, firecracker5, spreadFragmentation, spreadFragmentation8, focusedFragmentation, spreadConcussion, spreadConcussion8, focusedConcussion, spreadFlash, spreadFlash8, focusedFlash, singleSpark, glassPiece, focusedGlass, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, smoke, boilingWater, glue, waste, mistAntiSlow, mistAntidote, mistSleep, denseShower, sparseShower, protectingBalmMelee, protectingBalmRanged, defenselessnessRunout, resolutionDust, hasteSpray, spreadNitrogen, spreadNitrogen8, focusedNitrogen,  eyeDrop, ironFiling, smellyDroplet, eyeShine, whiskeySpray, youthSprinkle, poisonCloud, pingFlash, blastNoSkMove, blastNoSkMelee, blastNoSkDisplace, blastNoSkAlter, blastNoSkWait, blastNoSkMoveItem, blastNoSkProject, blastNoSkApply, blastBonusSkMove, blastBonusSkMelee, blastBonusSkDisplace, blastBonusSkAlter, blastBonusSkWait, blastBonusSkMoveItem, blastBonusSkProject, blastBonusSkApply :: ItemKind++-- We take care (e.g., in burningOil below) that blasts are not faster+-- than 100% fastest natural speed, or some frames would be skipped,+-- which is a waste of perfectly good frames.++-- * Parameterized blasts++spreadBurningOil :: Int -> GroupName ItemKind -> ItemKind+spreadBurningOil n grp = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "burning oil"+  , ifreq    = [(grp, 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = intToDice (4 + n * 2)+  , irarity  = [(1, 1)]+  , iverbHit = "sear"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity (max 10 $ min 100 $ n `div` 2 * 10)+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 2 ]+  , ieffects = [ Burn 1+               , toOrganBad S_PACIFIED (2 + 1 `d` 2) ]+                   -- slips and frantically puts out fire+  , idesc    = "Sticky oil, burning brightly."+  , ikit     = []+  }+spreadBurningOil2 = spreadBurningOil 2 S_VIOLENT_BURNING_OIL_2+                      -- 2 steps, 2 turns+spreadBurningOil3 = spreadBurningOil 3 S_VIOLENT_BURNING_OIL_3+                      -- 2 steps, 2 turns+spreadBurningOil4 = spreadBurningOil 4 S_VIOLENT_BURNING_OIL_4+                      -- 4 steps, 2 turns+spreadBurningOil8 :: Int -> GroupName ItemKind -> ItemKind+spreadBurningOil8 n grp = (spreadBurningOil (n `div` 2) grp)+  { icount   = 7  -- 8 was too deadly+  }+spreadBurningOil82 = spreadBurningOil8 2 S_BURNING_OIL_2+spreadBurningOil83 = spreadBurningOil8 3 S_BURNING_OIL_3+spreadBurningOil84 = spreadBurningOil8 4 S_BURNING_OIL_4+focusedBurningOil :: Int -> GroupName ItemKind -> GroupName ItemKind -> ItemKind+focusedBurningOil n grp grpExplode = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "igniting oil"+  , ifreq    = [(grp, 1)]+  , iflavour = zipPlain [BrYellow]  -- all ignitions yellow to avoid appearing+                                    -- as a small vial explosion+  , icount   = intToDice n+  , irarity  = [(1, 1)]+  , iverbHit = "ignite"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 0  -- 0 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+      -- when the target position is occupied, the explosion starts one step+      -- away, hence we set range to 0 steps, to limit dispersal+  , ieffects = [OnSmash $ Explode grpExplode]+  , idesc    = idesc spreadBurningOil2+  , ikit     = []+  }+focusedBurningOil2 = focusedBurningOil 2 S_FOCUSED_BURNING_OIL_2 S_BURNING_OIL_2+focusedBurningOil3 = focusedBurningOil 3 S_FOCUSED_BURNING_OIL_3 S_BURNING_OIL_3+focusedBurningOil4 = focusedBurningOil 4 S_FOCUSED_BURNING_OIL_4 S_BURNING_OIL_4+firecracker :: Int -> ItemKind+firecracker n = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "firecracker"+  , ifreq    = [(if n == 5+                 then S_FIRECRACKER+                 else firecrackerAt n, 1)]+  , iflavour = zipPlain [brightCol !! ((n + 2) `mod` length brightCol)]+  , icount   = if n <= 3 then 1 `d` min 2 n else 2 + 1 `d` 2+  , irarity  = [(1, 1)]+  , iverbHit = if n >= 4 then "singe" else "crack"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine $ intToDice $ 1 + n `div` 2 ]+  , ieffects = [if n >= 4 then Burn 1 else RefillCalm (-2)]+               ++ [Discharge 1 30 | n >= 3]+               ++ [OnSmash $ Explode $ firecrackerAt (n - 1) | n >= 2]+  , idesc    = "Scraps of burnt paper, covering little pockets of black powder, buffeted by colorful explosions."+  , ikit     = []+  }+firecracker5 = firecracker 5+firecracker4 = firecracker 4+firecracker3 = firecracker 3+firecracker2 = firecracker 2+firecracker1 = firecracker 1++-- * Focused blasts++spreadFragmentation = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "fragmentation burst"+  , ifreq    = [(S_VIOLENT_FRAGMENTATION, 1)]+  , iflavour = zipPlain [Red]+  , icount   = 8  -- strong but few, so not always hits target+  , irarity  = [(1, 1)]+  , iverbHit = "tear apart"+  , iweight  = 1+  , idamage  = 3 `d` 1  -- deadly and adjacent actor hit by 2 on average;+                        -- however, moderate armour blocks completely+  , iaspects = [ ToThrow $ ThrowMod 100 20 4  -- 4 steps, 1 turn+               , SetFlag Lobable, SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 3, AddSkill SkHurtMelee $ -12 * 5 ]+  , ieffects = [DropItem 1 1 COrgan CONDITION]+  , idesc    = "Flying shards, flame and smoke."+  , ikit     = []+  }+spreadFragmentation8 = spreadFragmentation+  { ifreq    = [(S_FRAGMENTATION, 1)]+  , icount   = 5+  , iaspects = [ ToThrow $ ThrowMod 100 10 2  -- 2 steps, 1 turn+               , SetFlag Lobable, SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 3, AddSkill SkHurtMelee $ -12 * 5 ]+      -- smaller radius, so worse for area effect, but twice the direct damage+  }+focusedFragmentation = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "deflagration ignition"  -- black powder+  , ifreq    = [(S_FOCUSED_FRAGMENTATION, 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 3  -- 15 in total vs 8, higher spread+  , irarity  = [(1, 1)]+  , iverbHit = "ignite"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 0  -- 0 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+      -- when the target position is occupied, the explosion starts one step+      -- away, hence we set range to 0 steps, to limit dispersal+  , ieffects = [OnSmash $ Explode S_FRAGMENTATION]+  , idesc    = idesc spreadFragmentation+  , ikit     = []+  }+spreadConcussion = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "concussion blast"+  , ifreq    = [(S_VIOLENT_CONCUSSION, 1)]+  , iflavour = zipPlain [Magenta]+  , icount   = 12  -- pushing sometimes gets the victim out of attacker range,+                   -- but also sometimes moves to a position hit again later+  , irarity  = [(1, 1)]+  , iverbHit = "shock"+  , iweight  = 1+  , idamage  = 1 `d` 1  -- only air pressure, so not as deadly as fragmentation,+                        -- but armour can't block completely that easily+  , iaspects = [ ToThrow $ ThrowMod 100 20 4  -- 4 steps, 1 turn+               , SetFlag Lobable, SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 3, AddSkill SkHurtMelee $ -8 * 5 ]+      -- outdoors it has short range, but we only model indoors in the game;+      -- it's much faster than black powder shock wave, but we are beyond+      -- human-noticeable speed differences on short distances anyway+  , ieffects = [ DropItem maxBound 1 CEqp ARMOR_MISC+               , PushActor (ThrowMod 400 25 1)  -- 1 step, fast; after DropItem+                   -- this produces spam for braced actors; too bad+               , toOrganBad S_IMMOBILE 1  -- no balance+               , toOrganBad S_DEAFENED 23 ]+  , idesc    = "Shock wave, hot gases, some fire and smoke."+  , ikit     = []+  }+spreadConcussion8 = spreadConcussion+  { ifreq    = [(S_CONCUSSION, 1)]+  , icount   = 6+  , iaspects = [ ToThrow $ ThrowMod 100 10 2  -- 2 steps, 1 turn+               , SetFlag Lobable, SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 3, AddSkill SkHurtMelee $ -8 * 5 ]+  }+focusedConcussion = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "detonation ignition"  -- nitroglycerine+  , ifreq    = [(S_FOCUSED_CONCUSSION, 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 4  -- 24 in total vs 12, higher spread, less harm from pushing+  , irarity  = [(1, 1)]+  , iverbHit = "ignite"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 0  -- 0 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [OnSmash $ Explode S_CONCUSSION]+  , idesc    = idesc spreadConcussion+  , ikit     = []+  }+spreadFlash = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "magnesium flash"+  , ifreq    = [(S_VIOLENT_FLASH, 1)]+  , iflavour = zipPlain [BrWhite]+  , icount   = 13+  , irarity  = [(1, 1)]+  , iverbHit = "dazzle"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ ToThrow $ ThrowMod 100 20 4  -- 4 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 5 ]+  , ieffects = [ toOrganBad S_BLIND 5+               , toOrganBad S_WEAKENED 20 ]+                 -- Wikipedia says: blind for five seconds and afterimage+                 -- for much longer, harming aim+  , idesc    = "A very bright flash of fire, causing long-lasting afterimages."+  , ikit     = []+  }+spreadFlash8 = spreadFlash+  { iname    = "spark"+  , ifreq    = [(S_SPARK, 1)]+  , icount   = 5+  , iverbHit = "singe"+  , iaspects = [ ToThrow $ ThrowMod 100 10 2  -- 2 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 5 ]+  }+focusedFlash = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "magnesium ignition"+  , ifreq    = [(S_FOCUSED_FLASH, 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 5  -- 25 in total vs 13, higher spread+  , irarity  = [(1, 1)]+  , iverbHit = "ignite"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 0  -- 0 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [OnSmash $ Explode S_SPARK]+  , idesc    = idesc spreadFlash+  , ikit     = []+  }+singleSpark = spreadFlash+  { iname    = "single spark"+  , ifreq    = [(S_SINGLE_SPARK, 1)]  -- too weak to start a fire+  , icount   = 1+  , iverbHit = "spark"+  , iaspects = [ toLinger 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 3 ]+  , ieffects = []+  , idesc    = "A glowing ember."+  , ikit     = []+  }+glassPiece = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "glass piece"+  , ifreq    = [(S_GLASS_HAIL, 1)]+  , iflavour = zipPlain [Blue]+  , icount   = 6+  , irarity  = [(1, 1)]+  , iverbHit = "cut"+  , iweight  = 1+  , idamage  = 2 `d` 1+  , iaspects = [ ToThrow $ ThrowMod 100 10 4  -- 2 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkHurtMelee $ -15 * 5 ]+                 -- brittle, not too dense; armor blocks+  , ieffects = []+  , idesc    = "Swift, sharp edges."+  , ikit     = []+  }+focusedGlass = glassPiece  -- when blowing up windows+  { ifreq    = [(S_FOCUSED_GLASS_HAIL, 1)]+  , icount   = 2+  , iaspects = [ toLinger 0  -- 0 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkHurtMelee $ -15 * 5 ]+  , ieffects = [OnSmash $ Explode S_GLASS_HAIL]+  }++-- * Assorted blasts that don't induce conditions or not used mainly for them++fragrance = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "fragrance"  -- instant, fast fragrance+  , ifreq    = [(S_FRAGRANCE, 1)]+  , iflavour = zipPlain [Magenta]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "engulf"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ ToThrow $ ThrowMod 200 5 1  -- 2 steps, .5 turn (necklaces)+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [Impress, toOrganGood S_ROSE_SMELLING 45]+  -- Linger 10, because sometimes it takes 2 turns due to starting just+  -- before actor turn's end (e.g., via a necklace).+  , idesc    = "A pleasant scent."+  , ikit     = []+  }+pheromone = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "musky whiff"  -- a kind of mist rather than fragrance+  , ifreq    = [(S_PHEROMONE, 1)]+  , iflavour = zipPlain [BrMagenta]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "tempt"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 10  -- 2 steps, 2 turns+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [Dominate]+  , idesc    = "A sharp, strong scent."+  , ikit     = []+  }+mistCalming = ItemKind  -- unused+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"+  , ifreq    = [(S_CALMING_MIST, 1)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "sooth"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [RefillCalm 2]+  , idesc    = "A soothing, gentle cloud."+  , ikit     = []+  }+odorDistressing = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "distressing whiff"+  , ifreq    = [(S_DISTRESSING_ODOR, 1)]+  , iflavour = zipFancy [BrRed]  -- salmon+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "distress"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 10  -- 2 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [ RefillCalm (-10)+               , toOrganBad S_FOUL_SMELLING (20 + 1 `d` 5)+               , toOrganBad S_IMPATIENT (2 + 1 `d` 2) ]+  , idesc    = "It turns the stomach."  -- and so can't stand still+  , ikit     = []+  }+mistHealing = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"  -- powerful, so slow and narrow+  , ifreq    = [(S_HEALING_MIST, 1)]+  , iflavour = zipFancy [BrGreen]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "revitalize"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 1 ]+  , ieffects = [RefillHP 2]+  , idesc    = "It fills the air with light and life."+  , ikit     = []+  }+mistHealing2 = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"+  , ifreq    = [(S_HEALING_MIST_2, 1)]+  , iflavour = zipPlain [Green]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "revitalize"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 2 ]+  , ieffects = [RefillHP 4]+  , idesc    = "At its touch, wounds close and bruises fade."+  , ikit     = []+  }+mistWounding = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"+  , ifreq    = [(S_WOUNDING_MIST, 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "devitalize"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [RefillHP (-2)]+  , idesc    = "The air itself stings and itches."+  , ikit     = []+  }+distortion = ItemKind+  { isymbol  = toContentSymbol 'v'+  , iname    = "vortex"+  , ifreq    = [(S_DISTORTION, 1)]+  , iflavour = zipPlain [White]+  , icount   = 8  -- braced are immune to Teleport; avoid failure messages+  , irarity  = [(1, 1)]+  , iverbHit = "engulf"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 10  -- 2 steps, 1 turn+               , SetFlag Lobable, SetFlag Fragile, SetFlag Blast ]+  , ieffects = [Teleport $ 15 + 1 `d` 10]+  , idesc    = "The air shifts oddly, as though light is being warped."+  , ikit     = []+  }+smoke = ItemKind  -- when stuff burns out  -- unused+  { isymbol  = toContentSymbol '`'+  , iname    = "smoke fume"  -- pluralizes better than 'smokes'+  , ifreq    = [(S_SMOKE, 1)]+  , iflavour = zipPlain [BrBlack]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "choke"  -- or "obscure"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 20  -- 4 steps, 2 turns+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [toOrganBad S_WITHHOLDING (5 + 1 `d` 3)]+                  -- choking and tears, can roughly see, but not aim+  , idesc    = "Twirling clouds of grey smoke."+  , ikit     = []+  }+boilingWater = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "boiling water"+  , ifreq    = [(S_BOILING_WATER, 1)]+  , iflavour = zipPlain [White]+  , icount   = 17  -- 18 causes 3 particles to hit the same actor 3 tiles away+  , irarity  = [(1, 1)]+  , iverbHit = "boil"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 30  -- 6 steps, 2 turns+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [Burn 1]+  , idesc    = "It bubbles and hisses."+  , ikit     = []+  }+glue = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "hoof glue"+  , ifreq    = [(S_GLUE, 1)]+  , iflavour = zipPlain [Cyan]+  , icount   = 8  -- Paralyze doesn't stack; avoid failure messages+  , irarity  = [(1, 1)]+  , iverbHit = "glue"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 10  -- 2 steps, 2 turns+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [Paralyze 10]+  , idesc    = "Thick and clinging."+  , ikit     = []+  }+waste = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "waste piece"+  , ifreq    = [(S_WASTE, 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "splosh"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [ toOrganBad S_FOUL_SMELLING (30 + 1 `d` 10)+               , toOrganBad S_DISPOSSESSED (10 + 1 `d` 5) ]+  , idesc    = "Sodden and foul-smelling."+  , ikit     = []+  }+mistAntiSlow = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"+  , ifreq    = [(S_ANTI_SLOW_MIST, 1)]+  , iflavour = zipFancy [BrYellow]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "propel"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [DropItem 1 1 COrgan S_SLOWED]+  , idesc    = "A cleansing rain."+  , ikit     = []+  }+mistAntidote = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"+  , ifreq    = [(S_ANTIDOTE_MIST, 1)]+  , iflavour = zipFancy [BrBlue]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "cure"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [DropItem 1 maxBound COrgan S_POISONED]+  , idesc    = "Washes away death's dew."+  , ikit     = []+  }+mistSleep = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"+  , ifreq    = [(S_SLEEP_MIST, 1)]+  , iflavour = zipFancy [BrMagenta]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "put to sleep"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [PutToSleep]+  , idesc    = "Lulls weary warriors."+  , ikit     = []+  }++-- * Condition-inducing blasts++-- Almost all have @toLinger 10@, that travels 2 steps in 1 turn.+-- These are very fast projectiles, not getting into the way of big+-- actors and not burdening the engine for long.+-- A few are slower 'mists'.++denseShower = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "dense shower"+  , ifreq    = [(S_DENSE_SHOWER, 1)]+  , iflavour = zipFancy [Green]+  , icount   = 12+  , irarity  = [(1, 1)]+  , iverbHit = "strengthen"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_STRENGTHENED 5]+  , idesc    = "A thick rain of droplets."+  , ikit     = []+  }+sparseShower = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "sparse shower"+  , ifreq    = [(S_SPARSE_SHOWER, 1)]+  , iflavour = zipFancy [Red]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "weaken"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganBad S_WEAKENED 7]+  , idesc    = "Light droplets that cling to clothing."+  , ikit     = []+  }+protectingBalmMelee = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "balm droplet"+  , ifreq    = [(S_MELEE_PROTECTIVE_BALM, 1)]+  , iflavour = zipFancy [Brown]+  , icount   = 6+  , irarity  = [(1, 1)]+  , iverbHit = "balm"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 0  -- 0 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [toOrganGood S_PROTECTED_FROM_MELEE (3 + 1 `d` 3)]+  , idesc    = "A thick ointment that hardens the skin."+  , ikit     = []+  }+protectingBalmRanged = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "balm droplet"+  , ifreq    = [(S_RANGE_PROTECTIVE_BALM, 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "balm"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_PROTECTED_FROM_RANGED (3 + 1 `d` 3)]+  , idesc    = "Grease that protects from flying death."+  , ikit     = []+  }+defenselessnessRunout = ItemKind+  { isymbol  = toContentSymbol '?'+  , iname    = "PhD defense question"+  , ifreq    = [(S_DEFENSELESSNESS_RUNOUT, 1)]+  , iflavour = zipFancy [BrRed]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "nag"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganBad S_DEFENSELESS (3 + 1 `d` 3)]+  , idesc    = "Only the most learned make use of this."+  , ikit     = []+  }+resolutionDust = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "resolution dust"+  , ifreq    = [(S_RESOLUTION_DUST, 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "calm"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_RESOLUTE (3 + 1 `d` 3)]+                 -- short enough duration that @calmEnough@ not a big problem+  , idesc    = "A handful of honest earth, to strengthen the soul."+  , ikit     = []+  }+hasteSpray = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "haste spray"+  , ifreq    = [(S_HASTE_SPRAY, 1)]+  , iflavour = zipFancy [BrYellow]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "haste"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_HASTED (3 + 1 `d` 3)]+  , idesc    = "A quick spurt."+  , ikit     = []+  }+spreadNitrogen = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "slowness mist"+  , ifreq    = [(S_VIOLENT_SLOWNESS_MIST, 1)]+  , iflavour = zipPlain [BrBlack]+  , icount   = 15+  , irarity  = [(1, 1)]+  , iverbHit = "freeze"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 10  -- 2 steps, 2 turns, mist, slow+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [toOrganBad S_SLOWED (2 + 1 `d` 3)]+  , idesc    = "Colourless cold clammy fog, making each movement an effort."+  , ikit     = []+  }+spreadNitrogen8 = spreadNitrogen+  { ifreq    = [(S_SLOWNESS_MIST, 1)]+  , icount   = 7+  , iaspects = [ toVelocity 5  -- 1 step, 1 turn, mist, slow+               , SetFlag Fragile, SetFlag Blast ]+  }+focusedNitrogen = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "slowness mist droplet"+  , ifreq    = [(S_FOCUSED_SLOWNESS_MIST, 1)]+  , iflavour = zipFancy [White]+  , icount   = 4 -- 28 in total vs 15, higher spread+  , irarity  = [(1, 1)]+  , iverbHit = "freeze"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toLinger 0  -- 0 steps, 1 turn+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [ OnSmash $ Explode S_SLOWNESS_MIST+               , toOrganBad S_SLOWED (2 + 1 `d` 3) ]+  , idesc    = "Colourless and colder than ice."+  , ikit     = []+  }+eyeDrop = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "eye drop"+  , ifreq    = [(S_EYE_DROP, 1)]+  , iflavour = zipFancy [BrCyan]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "cleanse"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_FAR_SIGHTED (3 + 1 `d` 3)]+  , idesc    = "Not to be taken orally."+  , ikit     = []+  }+ironFiling = ItemKind  -- fast, short, strongly blinding blast+  { isymbol  = toContentSymbol '`'+  , iname    = "iron filing"+  , ifreq    = [(S_IRON_FILING, 1)]+  , iflavour = zipPlain [Red]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "blind"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganBad S_BLIND (10 + 1 `d` 10)]+  , idesc    = "A shaving of bright metal."+  , ikit     = []+  }+smellyDroplet = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "smelly droplet"+  , ifreq    = [(S_SMELLY_DROPLET, 1)]+  , iflavour = zipFancy [Blue]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "sensitize"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_KEEN_SMELLING (5 + 1 `d` 3)]+  , idesc    = "A viscous lump that stains the skin."+  , ikit     = []+  }+eyeShine = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "eye shine"+  , ifreq    = [(S_EYE_SHINE, 1)]+  , iflavour = zipFancy [Cyan]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "smear"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_SHINY_EYED (3 + 1 `d` 3)]+  , idesc    = "They almost glow in the dark."+  , ikit     = []+  }+whiskeySpray = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "whiskey spray"+  , ifreq    = [(S_WHISKEY_SPRAY, 1)]+  , iflavour = zipFancy [Brown]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "inebriate"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [toOrganGood S_DRUNK (3 + 1 `d` 3)]+  , idesc    = "It burns in the best way."+  , ikit     = []+  }+youthSprinkle = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "youth sprinkle"+  , ifreq    = [(S_YOUTH_SPRINKLE, 1)]+  , iflavour = zipFancy [BrGreen]+  , icount   = 16+  , irarity  = [(1, 1)]+  , iverbHit = "sprinkle"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [toLinger 10, SetFlag Fragile, SetFlag Blast]+  , ieffects = [ toOrganGood S_ROSE_SMELLING (40 + 1 `d` 20)+               , toOrganNoTimer S_REGENERATING ]+  , idesc    = "Bright and smelling of the Spring."+  , ikit     = []+  }+poisonCloud = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "poison cloud"+  , ifreq    = [(S_POISON_CLOUD, 1)]+  , iflavour = zipFancy [BrMagenta]+  , icount   = 11  -- low, to be less deadly in a tunnel, compared to single hit+  , irarity  = [(1, 1)]+  , iverbHit = "poison"+  , iweight  = 0  -- lingers, blocking path+  , idamage  = 0+  , iaspects = [ ToThrow $ ThrowMod 10 100 2  -- 2 steps, 2 turns+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [toOrganNoTimer S_POISONED]+  , idesc    = "Choking gas that stings the eyes."+  , ikit     = []+  }+pingFlash = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "flash"+  , ifreq    = [(S_PING_PLASH, 1)]+  , iflavour = zipFancy [Green]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "ping"+  , iweight  = 1  -- to prevent blocking the way+  , idamage  = 0+  , iaspects = [ ToThrow $ ThrowMod 200 0 1  -- 1 step, .5 turn (necklaces)+               , SetFlag Fragile, SetFlag Blast+               , AddSkill SkShine 2 ]+  , ieffects = [OnSmash Yell]+  , idesc    = "A ping and a display flash from an echolocator out of sync momentarily."+  , ikit     = []+  }+blastNoStat :: GroupName ItemKind -> ItemKind+blastNoStat grp = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "mist"+  , ifreq    = [(blastNoStatOf grp, 1)]+  , iflavour = zipFancy [White]+  , icount   = 12+  , irarity  = [(1, 1)]+  , iverbHit = "drain"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 10  -- 2 steps, 2 turns+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [toOrganBad grp (3 + 1 `d` 3)]+  , idesc    = "Completely disables one personal faculty."+  , ikit     = []+  }+blastNoSkMove = blastNoStat S_IMMOBILE+blastNoSkMelee = blastNoStat S_PACIFIED+blastNoSkDisplace = blastNoStat S_IRREPLACEABLE+blastNoSkAlter = blastNoStat S_RETAINING+blastNoSkWait = blastNoStat S_IMPATIENT+blastNoSkMoveItem = blastNoStat S_DISPOSSESSED+blastNoSkProject = blastNoStat S_WITHHOLDING+blastNoSkApply = blastNoStat S_PARSIMONIOUS+blastBonusStat :: GroupName ItemKind -> ItemKind+blastBonusStat grp = ItemKind+  { isymbol  = toContentSymbol '`'+  , iname    = "dew"+  , ifreq    = [(blastBonusStatOf grp, 1)]+  , iflavour = zipFancy [White]+  , icount   = 12+  , irarity  = [(1, 1)]+  , iverbHit = "elevate"+  , iweight  = 1+  , idamage  = 0+  , iaspects = [ toVelocity 10  -- 2 steps, 2 turns+               , SetFlag Fragile, SetFlag Blast ]+  , ieffects = [toOrganGood grp (20 + 1 `d` 5)]+  , idesc    = "Temporarily enhances the given personal faculty."+  , ikit     = []+  }+blastBonusSkMove = blastBonusStat S_MORE_MOBILE+blastBonusSkMelee = blastBonusStat S_MORE_COMBATIVE+blastBonusSkDisplace = blastBonusStat S_MORE_DISPLACING+blastBonusSkAlter = blastBonusStat S_MORE_MODIFYING+blastBonusSkWait = blastBonusStat S_MORE_PATIENT+blastBonusSkMoveItem = blastBonusStat S_MORE_TIDY+blastBonusSkProject = blastBonusStat S_MORE_PROJECTING+blastBonusSkApply = blastBonusStat S_MORE_PRACTICAL
+ GameDefinition/Content/ItemKindEmbed.hs view
@@ -0,0 +1,412 @@+-- | Definitions of items embedded in map tiles.+module Content.ItemKindEmbed+  ( -- * Group name patterns+    pattern SCRATCH_ON_WALL, pattern OBSCENE_PICTOGRAM, pattern SUBTLE_FRESCO, pattern TREASURE_CACHE, pattern TREASURE_CACHE_TRAP, pattern SIGNAGE, pattern SMALL_FIRE, pattern BIG_FIRE, pattern FROST, pattern RUBBLE, pattern DOORWAY_TRAP_UNKNOWN, pattern DOORWAY_TRAP, pattern STAIRS_UP, pattern STAIRS_DOWN, pattern ESCAPE, pattern STAIRS_TRAP_UP, pattern STAIRS_TRAP_DOWN, pattern LECTERN, pattern SHALLOW_WATER, pattern STRAIGHT_PATH, pattern FROZEN_GROUND+  , embedsGN+  , -- * Content+    embeds+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Core.Dice+import Game.LambdaHack.Definition.Ability+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal+import Game.LambdaHack.Definition.Flavour++import Content.ItemKindActor+import Content.ItemKindBlast+import Content.ItemKindTemporary++-- * Group name patterns++embedsGN :: [GroupName ItemKind]+embedsGN =+       [SCRATCH_ON_WALL, OBSCENE_PICTOGRAM, SUBTLE_FRESCO, TREASURE_CACHE, TREASURE_CACHE_TRAP, SIGNAGE, SMALL_FIRE, BIG_FIRE, FROST, RUBBLE, DOORWAY_TRAP_UNKNOWN, DOORWAY_TRAP, STAIRS_UP, STAIRS_DOWN, ESCAPE, STAIRS_TRAP_UP, STAIRS_TRAP_DOWN, LECTERN, SHALLOW_WATER, STRAIGHT_PATH, FROZEN_GROUND]++pattern SCRATCH_ON_WALL, OBSCENE_PICTOGRAM, SUBTLE_FRESCO, TREASURE_CACHE, TREASURE_CACHE_TRAP, SIGNAGE, SMALL_FIRE, BIG_FIRE, FROST, RUBBLE, DOORWAY_TRAP_UNKNOWN, DOORWAY_TRAP, STAIRS_UP, STAIRS_DOWN, ESCAPE, STAIRS_TRAP_UP, STAIRS_TRAP_DOWN, LECTERN, SHALLOW_WATER, STRAIGHT_PATH, FROZEN_GROUND :: GroupName ItemKind++pattern SCRATCH_ON_WALL = GroupName "scratch on wall"+pattern OBSCENE_PICTOGRAM = GroupName "obscene pictogram"+pattern SUBTLE_FRESCO = GroupName "subtle fresco"+pattern TREASURE_CACHE = GroupName "treasure cache"+pattern TREASURE_CACHE_TRAP = GroupName "treasure cache trap"+pattern SIGNAGE = GroupName "signage"+pattern SMALL_FIRE = GroupName "small fire"+pattern BIG_FIRE = GroupName "big fire"+pattern FROST = GroupName "frozen mass"+pattern RUBBLE = GroupName "rubble"+pattern DOORWAY_TRAP_UNKNOWN = GroupName "doorway trap unknown"+pattern DOORWAY_TRAP = GroupName "doorway trap"+pattern STAIRS_UP = GroupName "stairs up"+pattern STAIRS_DOWN = GroupName "stairs down"+pattern ESCAPE = GroupName "escape"+pattern STAIRS_TRAP_UP = GroupName "stairs trap up"+pattern STAIRS_TRAP_DOWN = GroupName "stairs trap down"+pattern LECTERN = GroupName "lectern"+pattern SHALLOW_WATER = GroupName "shallow water"+pattern STRAIGHT_PATH = GroupName "straight path"+pattern FROZEN_GROUND = GroupName "frozen ground"++-- * Content++embeds :: [ItemKind]+embeds =+  [scratchOnWall, obscenePictogram, subtleFresco, treasureCache, treasureCacheTrap, signageExit, signageEmbed, signageMerchandise, fireSmall, fireBig, frost, rubble, doorwayTrapTemplate, doorwayTrap1, doorwayTrap2, doorwayTrap3, stairsUp, stairsDown, escape, stairsTrapUp, stairsTrapDown, lectern, shallowWater, straightPath, frozenGround]++scratchOnWall,    obscenePictogram, subtleFresco, treasureCache, treasureCacheTrap, signageExit, signageEmbed, signageMerchandise, fireSmall, fireBig, frost, rubble, doorwayTrapTemplate, doorwayTrap1, doorwayTrap2, doorwayTrap3, stairsUp, stairsDown, escape, stairsTrapUp, stairsTrapDown, lectern, shallowWater, straightPath, frozenGround :: ItemKind+++-- Make sure very few walls are substantially useful, e.g., caches,+-- and none that are secret. Otherwise the player will spend a lot of time+-- bumping walls, which is boring compared to fights or dialogues+-- and ever worse, the player will bump all secret walls, wasting time+-- and foregoing the fun of guessing how to find entrance to a disjoint part+-- of the level by bumping the least number of secret walls.+scratchOnWall = ItemKind+  { isymbol  = toContentSymbol '?'+  , iname    = "claw mark"+  , ifreq    = [(SCRATCH_ON_WALL, 1)]+  , iflavour = zipPlain [BrBlack]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "scratch"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [ VerbMsg "start making sense of the scratches" "."+               , Detect DetectHidden 4 ]+  , idesc    = "A seemingly random series of scratches, carved deep into the wall."+  , ikit     = []+  }+obscenePictogram = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "obscene pictogram"+  , ifreq    = [(OBSCENE_PICTOGRAM, 1)]+  , iflavour = zipPlain [BrMagenta]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "infuriate"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = [Timeout 7, SetFlag Durable]+  , ieffects = [ VerbMsg "enter destructive rage at the sight of an obscene pictogram" "."+               , RefillCalm (-20)+               , OneOf [ toOrganGood S_STRENGTHENED (3 + 1 `d` 2)+                       , CreateItem Nothing CGround S_SANDSTONE_ROCK timerNone ]+               ]+  , idesc    = "It's not even anatomically possible."+  , ikit     = []+  }+subtleFresco = ItemKind+  { isymbol  = toContentSymbol '*'+  , iname    = "subtle fresco"+  , ifreq    = [(SUBTLE_FRESCO, 1)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "sooth"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = [Timeout 7, SetFlag Durable]+  , ieffects = [ VerbMsg "feel refreshed by the subtle fresco" "."+               , toOrganGood S_FAR_SIGHTED (3 + 1 `d` 2)+               , toOrganGood S_KEEN_SMELLING (3 + 1 `d` 2) ]+                 -- hearing gets a boost through bracing, so no need here+  , idesc    = "Expensive yet tasteful."+  , ikit     = []+  }+treasureCache = ItemKind+  { isymbol  = toContentSymbol 'o'+  , iname    = "treasure cache"+  , ifreq    = [(TREASURE_CACHE, 1)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "crash"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [CreateItem Nothing CGround COMMON_ITEM timerNone]+  , idesc    = "Glittering treasure, just waiting to be taken."+  , ikit     = []+  }+reliefMsg :: Effect+reliefMsg = VerbMsg "sigh with relief when nothing explodes in your face!" ""+treasureCacheTrap = ItemKind+  { isymbol  = toContentSymbol '^'+  , iname    = "cache trap"+  , ifreq    = [(TREASURE_CACHE_TRAP, 1)]+  , iflavour = zipPlain [Red]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "taint"+  , iweight  = 1000+  , idamage  = 0+  , iaspects = []  -- not Durable, springs at most once+  , ieffects = [OneOf [ toOrganBad S_BLIND (10 + 1 `d` 10)+                      , RefillCalm (-99)+                      , Explode S_FOCUSED_CONCUSSION+                      , reliefMsg, reliefMsg ]]+  , idesc    = "It's a trap!"+  , ikit     = []+  }+signageExit = ItemKind+  { isymbol  = toContentSymbol '?'+  , iname    = "inscription"+  , ifreq    = [(SIGNAGE, 100)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "whack"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [Detect DetectExit 100]+  , idesc    = "Crude big arrows hastily carved by unknown hands."+  , ikit     = []+  }+signageEmbed = signageExit+  { iname    = "notice"+  , ifreq    = [(SIGNAGE, 100)]+  , iflavour = zipPlain [Cyan]+  , ieffects = [Detect DetectEmbed 12]+  , idesc    = "The battered poster is untitled and unsigned."+  }+signageMerchandise = signageExit+  { iname    = "treasure map"+  , ifreq    = [(SIGNAGE, 100)]+  , iflavour = zipPlain [BrCyan]+  , ieffects = [Detect DetectLoot 20]+  , idesc    = "In equal parts cryptic and promising."+  }+fireSmall = ItemKind+  { isymbol  = toContentSymbol 'o'+  , iname    = "small fire"+  , ifreq    = [(SMALL_FIRE, 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "burn"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [Burn 1, Explode S_SINGLE_SPARK]+  , idesc    = "A few small logs, burning brightly."+  , ikit     = []+  }+fireBig = fireSmall+  { isymbol  = toContentSymbol '0'+  , iname    = "big fire"+  , ifreq    = [(BIG_FIRE, 1)]+  , iflavour = zipPlain [Red]+  , ieffects = [ Burn 2+               , CreateItem Nothing CGround S_WOODEN_TORCH timerNone+               , Explode S_SPARK ]+  , idesc    = "Glowing with light and warmth."+  , ikit     = []+  }+frost = ItemKind+  { isymbol  = toContentSymbol '^'+  , iname    = "frost"+  , ifreq    = [(FROST, 1)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "burn"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [ Burn 1  -- sensory ambiguity between hot and cold+               , RefillCalm 20  -- cold reason+               , PushActor (ThrowMod 400 10 1) ]  -- slippery ice+  , idesc    = "Intricate patterns of shining ice."+  , ikit     = []+  }+rubble = ItemKind+  { isymbol  = toContentSymbol '&'+  , iname    = "rubble"+  , ifreq    = [(RUBBLE, 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "bury"+  , iweight  = 100000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [OneOf [ Explode S_FOCUSED_GLASS_HAIL+                      , Summon MOBILE_ANIMAL $ 1 `dL` 2+                      , toOrganNoTimer S_POISONED+                      , CreateItem Nothing CGround ANY_ARROW timerNone+                      , CreateItem Nothing CGround STARTING_WEAPON timerNone+                      , reliefMsg, reliefMsg, reliefMsg+                      , reliefMsg, reliefMsg, reliefMsg ]]+  , idesc    = "Broken chunks of rock and glass."+  , ikit     = []+  }+doorwayTrapTemplate = ItemKind+  { isymbol  = toContentSymbol '+'+  , iname    = "doorway trap"+  , ifreq    = [(DOORWAY_TRAP_UNKNOWN, 1), (DOORWAY_TRAP, 0)]+      -- the void group needed to pick the item for tile triggering+      -- even when not yet identified+  , iflavour = zipPlain brightCol+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "cripple"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [PresentAs DOORWAY_TRAP_UNKNOWN]+      -- not Durable, springs at most once+  , ieffects = []+  , idesc    = "Just turn the handle..."+  , ikit     = []+  }+doorwayTrap1 = doorwayTrapTemplate+  { ifreq    = [(DOORWAY_TRAP, 50)]+  , ieffects = [toOrganBad S_BLIND $ (1 `dL` 4) * 5]+  -- , idesc    = ""+  }+doorwayTrap2 = doorwayTrapTemplate+  { ifreq    = [(DOORWAY_TRAP, 25)]+  , ieffects = [toOrganBad S_SLOWED $ (1 `dL` 4) * 10]+  -- , idesc    = ""+  }+doorwayTrap3 = doorwayTrapTemplate+  { ifreq    = [(DOORWAY_TRAP, 25)]+  , ieffects = [toOrganBad S_WEAKENED $ (1 `dL` 4) * 10 ]+  -- , idesc    = ""+  }+stairsUp = ItemKind+  { isymbol  = toContentSymbol '<'+  , iname    = "flight"+  , ifreq    = [(STAIRS_UP, 1)]+  , iflavour = zipPlain [BrWhite]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "crash"  -- the verb is only used when the item hits,+                        -- not when it's applied otherwise, e.g., from tile+  , iweight  = 100000+  , idamage  = 0+  , iaspects = [ELabel "of steps", SetFlag Durable]+  , ieffects = [Ascend True]+  , idesc    = "Stairs that rise towards escape."+  , ikit     = []+  }+stairsDown = stairsUp+  { isymbol  = toContentSymbol '>'+  , ifreq    = [(STAIRS_DOWN, 1)]+  , ieffects = [Ascend False]+  , idesc    = ""+  }+escape = stairsUp+  { isymbol  = toContentSymbol '>'+  , iname    = "way"+  , ifreq    = [(ESCAPE, 1)]+  , iflavour = zipPlain [BrGreen]+  , iaspects = [SetFlag Durable]+  , ieffects = [Escape]+  , idesc    = "May this nightmare have an end?"+                 -- generic escape, so the text should be too;+                 -- for moon outdoors, spaceship, everywhere+  }+stairsTrapUp = ItemKind+  { isymbol  = toContentSymbol '^'+  , iname    = "staircase trap"+  , ifreq    = [(STAIRS_TRAP_UP, 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "buffet"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = []  -- not Durable, springs at most once+  , ieffects = [ VerbMsgFail "be caught in an updraft" "."+               , Teleport $ 3 + 1 `dL` 10 ]+  , idesc    = "A hidden spring, to help the unwary soar."+  , ikit     = []+  }+-- Needs to be separate from stairsTrapUp, to make sure the item is+-- registered after up stairs (not only after down stairs)+-- so that effects are invoked in the proper order and, e.g., teleport works.+stairsTrapDown = stairsTrapUp+  { ifreq    = [(STAIRS_TRAP_DOWN, 1)]+  , iflavour = zipPlain [Red]+  , iverbHit = "open up under"+  , ieffects = [ VerbMsgFail "tumble down the stairwell" "."+               , toOrganGood S_DRUNK (20 + 1 `d` 5) ]+  , idesc    = "A treacherous slab, to teach those who are too proud."+  }+lectern = ItemKind+  { isymbol  = toContentSymbol '?'+  , iname    = "lectern"+  , ifreq    = [(LECTERN, 1)]+  , iflavour = zipFancy [BrYellow]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "ask"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = []  -- not Durable, springs at most once+  , ieffects = [ OneOf [ CreateItem Nothing CGround ANY_SCROLL timerNone+                       , Detect DetectAll 20+                       , toOrganBad S_DEFENSELESS $ (1 `dL` 6) * 10+                       , toOrganGood S_DRUNK (20 + 1 `d` 5) ]+               , Explode S_DEFENSELESSNESS_RUNOUT ]+  , idesc    = "A dark wood stand, where strange priests once preached."+  , ikit     = []+  }+shallowWater = ItemKind+  { isymbol  = toContentSymbol '~'+  , iname    = "shallow water"+  , ifreq    = [(SHALLOW_WATER, 1)]+  , iflavour = zipFancy [BrCyan]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "impede"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [ParalyzeInWater 2]+  , idesc    = ""+  , ikit     = []+  }+straightPath = ItemKind+  { isymbol  = toContentSymbol '.'+  , iname    = "straight path"+  , ifreq    = [(STRAIGHT_PATH, 1)]+  , iflavour = zipFancy [BrRed]+  , icount   = 1+  , irarity  = [(1, 1)]+  , iverbHit = "propel"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [SetFlag Durable]+  , ieffects = [InsertMove 2]+  , idesc    = ""+  , ikit     = []+  }+frozenGround = ItemKind+  { isymbol  = toContentSymbol '.'+  , iname    = "shade"+  , ifreq    = [(FROZEN_GROUND, 1)]+  , iflavour = zipFancy [BrBlue]+  , icount   = 10  -- very thick ice and refreezes, but not too large and boring+  , irarity  = [(1, 1)]+  , iverbHit = "betray"+  , iweight  = 10000+  , idamage  = 0+  , iaspects = [ELabel "of ice"]+                 -- no Durable or some items would be impossible to pick up+  , ieffects = [PushActor (ThrowMod 400 10 1)]+                  -- the high speed represents gliding rather than flying+                  -- and so no need to lift actor's weight off the ground;+                  -- low linger comes from abrupt halt over normal surface+  , idesc    = ""+  , ikit     = []+  }
GameDefinition/Content/ItemKindOrgan.hs view
@@ -1,259 +1,695 @@--- | Organ definitions.-module Content.ItemKindOrgan ( organs ) where+-- | Actor organ definitions.+module Content.ItemKindOrgan+  ( -- * Group name patterns+    pattern S_FIST, pattern S_FOOT, pattern S_HOOKED_CLAW, pattern S_SMALL_CLAW, pattern S_SNOUT, pattern S_SMALL_JAW, pattern S_JAW, pattern S_LARGE_JAW, pattern S_ANTLER, pattern S_HORN, pattern S_RHINO_HORN, pattern S_TENTACLE, pattern S_TIP, pattern S_LIP, pattern S_THORN, pattern S_BOILING_FISSURE, pattern S_ARSENIC_FISSURE, pattern S_SULFUR_FISSURE, pattern S_BEE_STING, pattern S_STING, pattern S_VENOM_TOOTH, pattern S_VENOM_FANG, pattern S_SCREECHING_BEAK, pattern S_LARGE_TAIL, pattern S_HUGE_TAIL, pattern S_ARMORED_SKIN, pattern S_BARK, pattern S_NOSTRIL, pattern S_RATLLE, pattern S_INSECT_MORTALITY, pattern S_SAPIENT_BRAIN, pattern S_ANIMAL_BRAIN, pattern S_SCENT_GLAND, pattern S_BOILING_VENT, pattern S_ARSENIC_VENT, pattern S_SULFUR_VENT, pattern S_EYE_3, pattern S_EYE_6, pattern S_EYE_8, pattern S_VISION_6, pattern S_VISION_12, pattern S_VISION_16, pattern S_EAR_3, pattern S_EAR_6, pattern S_EAR_8, pattern S_SPEED_GLAND_5, pattern S_SPEED_GLAND_10+  , pattern SCAVENGER+  , pattern S_TOOTH, pattern S_LASH, pattern S_RIGHT_TORSION, pattern S_LEFT_TORSION, pattern S_PUPIL+  , organsGNSingleton, organsGN+  , -- * Content+    organs+  ) where -import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Dice-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Msg+import Prelude ()++import Game.LambdaHack.Core.Prelude+ import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Core.Dice+import Game.LambdaHack.Definition.Ability+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal+import Game.LambdaHack.Definition.Flavour +import Content.ItemKindBlast+import Content.ItemKindTemporary+import Content.RuleKind++-- * Group name patterns++organsGNSingleton :: [GroupName ItemKind]+organsGNSingleton =+       [S_FIST, S_FOOT, S_HOOKED_CLAW, S_SMALL_CLAW, S_SNOUT, S_SMALL_JAW, S_JAW, S_LARGE_JAW, S_ANTLER, S_HORN, S_RHINO_HORN, S_TENTACLE, S_TIP, S_LIP, S_THORN, S_BOILING_FISSURE, S_ARSENIC_FISSURE, S_SULFUR_FISSURE, S_BEE_STING, S_STING, S_VENOM_TOOTH, S_VENOM_FANG, S_SCREECHING_BEAK, S_LARGE_TAIL, S_HUGE_TAIL, S_ARMORED_SKIN, S_BARK, S_NOSTRIL, S_RATLLE, S_INSECT_MORTALITY, S_SAPIENT_BRAIN, S_ANIMAL_BRAIN, S_SCENT_GLAND, S_BOILING_VENT, S_ARSENIC_VENT, S_SULFUR_VENT, S_EYE_3, S_EYE_6, S_EYE_8, S_VISION_6, S_VISION_12, S_VISION_16, S_EAR_3, S_EAR_6, S_EAR_8, S_SPEED_GLAND_5, S_SPEED_GLAND_10]+    ++ [S_TOOTH, S_LASH, S_RIGHT_TORSION, S_LEFT_TORSION, S_PUPIL]++pattern S_FIST, S_FOOT, S_HOOKED_CLAW, S_SMALL_CLAW, S_SNOUT, S_SMALL_JAW, S_JAW, S_LARGE_JAW, S_ANTLER, S_HORN, S_RHINO_HORN, S_TENTACLE, S_TIP, S_LIP, S_THORN, S_BOILING_FISSURE, S_ARSENIC_FISSURE, S_SULFUR_FISSURE, S_BEE_STING, S_STING, S_VENOM_TOOTH, S_VENOM_FANG, S_SCREECHING_BEAK, S_LARGE_TAIL, S_HUGE_TAIL, S_ARMORED_SKIN, S_BARK, S_NOSTRIL, S_RATLLE, S_INSECT_MORTALITY, S_SAPIENT_BRAIN, S_ANIMAL_BRAIN, S_SCENT_GLAND, S_BOILING_VENT, S_ARSENIC_VENT, S_SULFUR_VENT, S_EYE_3, S_EYE_6, S_EYE_8, S_VISION_6, S_VISION_12, S_VISION_16, S_EAR_3, S_EAR_6, S_EAR_8, S_SPEED_GLAND_5, S_SPEED_GLAND_10 :: GroupName ItemKind++pattern S_TOOTH, S_LASH, S_RIGHT_TORSION, S_LEFT_TORSION, S_PUPIL :: GroupName ItemKind++organsGN :: [GroupName ItemKind]+organsGN =+       [SCAVENGER]++pattern SCAVENGER :: GroupName ItemKind++pattern S_FIST = GroupName "fist"+pattern S_FOOT = GroupName "foot"+pattern S_HOOKED_CLAW = GroupName "hooked claw"+pattern S_SMALL_CLAW = GroupName "small claw"+pattern S_SNOUT = GroupName "snout"+pattern S_SMALL_JAW = GroupName "small jaw"+pattern S_JAW = GroupName "jaw"+pattern S_LARGE_JAW = GroupName "large jaw"+pattern S_ANTLER = GroupName "antler"+pattern S_HORN = GroupName "horn"+pattern S_RHINO_HORN = GroupName "rhino horn"+pattern S_TENTACLE = GroupName "tentacle"+pattern S_TIP = GroupName "tip"+pattern S_LIP = GroupName "lip"+pattern S_THORN = GroupName "thorn"+pattern S_BOILING_FISSURE = GroupName "boiling fissure"+pattern S_ARSENIC_FISSURE = GroupName "arsenic fissure"+pattern S_SULFUR_FISSURE = GroupName "sulfur fissure"+pattern S_BEE_STING = GroupName "bee sting"+pattern S_STING = GroupName "sting"+pattern S_VENOM_TOOTH = GroupName "venom tooth"+pattern S_VENOM_FANG = GroupName "venom fang"+pattern S_SCREECHING_BEAK = GroupName "screeching beak"+pattern S_LARGE_TAIL = GroupName "large tail"+pattern S_HUGE_TAIL = GroupName "huge tail"+pattern S_ARMORED_SKIN = GroupName "armored skin"+pattern S_BARK = GroupName "bark"+pattern S_NOSTRIL = GroupName "nostril"+pattern S_RATLLE = GroupName "rattle"+pattern S_INSECT_MORTALITY = GroupName "insect mortality"+pattern S_SAPIENT_BRAIN = GroupName "sapient brain"+pattern S_ANIMAL_BRAIN = GroupName "animal brain"+pattern S_SCENT_GLAND = GroupName "scent gland"+pattern S_BOILING_VENT = GroupName "boiling vent"+pattern S_ARSENIC_VENT = GroupName "arsenic vent"+pattern S_SULFUR_VENT = GroupName "sulfur vent"+pattern S_EYE_3 = GroupName "eye 3"+pattern S_EYE_6 = GroupName "eye 6"+pattern S_EYE_8 = GroupName "eye 8"+pattern S_VISION_6 = GroupName "vision 6"+pattern S_VISION_12 = GroupName "vision 12"+pattern S_VISION_16 = GroupName "vision 16"+pattern S_EAR_3 = GroupName "ear 3"+pattern S_EAR_6 = GroupName "ear 6"+pattern S_EAR_8 = GroupName "ear 8"+pattern S_SPEED_GLAND_5 = GroupName "speed gland 5"+pattern S_SPEED_GLAND_10 = GroupName "speed gland 10"++pattern SCAVENGER = GroupName "scavenger"++-- * LH-specific+pattern S_TOOTH = GroupName "tooth"+pattern S_LASH = GroupName "lash"+pattern S_RIGHT_TORSION = GroupName "right torsion"+pattern S_LEFT_TORSION = GroupName "left torsion"+pattern S_PUPIL = GroupName "pupil"++-- * Content+ organs :: [ItemKind] organs =-  [fist, foot, tentacle, lash, noseTip, lip, claw, smallClaw, snout, sting, venomTooth, venomFang, largeTail, jaw, largeJaw, tooth, pupil, armoredSkin, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, eye2, eye3, eye4, eye5, nostril, thorn, vent, fissure]+  [fist, foot, hookedClaw, smallClaw, snout, smallJaw, jaw, largeJaw, antler, horn, rhinoHorn, tentacle, tip, lip, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, hugeTail, armoredSkin, bark, eye3, eye6, eye8, vision6, vision12, vision16, nostril, ear3, ear6, ear8, rattleOrgan, insectMortality, sapientBrain, animalBrain, speedGland5, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP, braced, asleep, impressed]+  -- LH-specific+  ++ [tooth, lash, torsionRight, torsionLeft, pupil] -fist,    foot, tentacle, lash, noseTip, lip, claw, smallClaw, snout, sting, venomTooth, venomFang, largeTail, jaw, largeJaw, tooth, pupil, armoredSkin, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, eye2, eye3, eye4, eye5, nostril, thorn, vent, fissure :: ItemKind+fist,    foot, hookedClaw, smallClaw, snout, smallJaw, jaw, largeJaw, antler, horn, rhinoHorn, tentacle, tip, lip, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, hugeTail, armoredSkin, bark, eye3, eye6, eye8, vision6, vision12, vision16, nostril, ear3, ear6, ear8, rattleOrgan, insectMortality, sapientBrain, animalBrain, speedGland5, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP, braced, asleep, impressed :: ItemKind+-- LH-specific+tooth, lash, torsionRight, torsionLeft, pupil :: ItemKind --- * Parameterized organs+symbolWand :: ContentSymbol ItemKind+symbolWand = rsymbolWand $ ritemSymbols standardRules -speedGland :: Int -> ItemKind-speedGland n = fist-  { iname    = "speed gland"-  , ifreq    = [("speed gland" <+> tshow n, 100)]-  , icount   = 1-  , iverbHit = "spit at"-  , iaspects = [AddSpeed $ intToDice n, Periodic $ intToDice n]-  , ieffects = [RefillHP 1]-  , ifeature = [Durable, Identified]-  , idesc    = ""+-- * No-cooldown melee damage organs without effects++thorn = fist+  { isymbol  = symbolWand+  , iname    = "thorn"+  , ifreq    = [(S_THORN, 1)]+  , icount   = 2 + 1 `d` 2  -- unrealistic, but not boring+  , iverbHit = "puncture"+  , idamage  = 2 `d` 1+  , iaspects = [SetFlag Meleeable]  -- not Durable+  , ieffects = [VerbNoLonger "be not so thorny any more" "."]+  , idesc    = "Sharp yet brittle."   }-speedGland2 = speedGland 2-speedGland4 = speedGland 4-speedGland6 = speedGland 6-speedGland8 = speedGland 8-speedGland10 = speedGland 10-eye :: Int -> ItemKind-eye n = fist-  { iname    = "eye"-  , ifreq    = [("eye" <+> tshow n, 100)]-  , icount   = 2-  , iverbHit = "glare at"-  , iaspects = [AddSight (intToDice n)]-  , ieffects = []-  , ifeature = [Durable, Identified]+tip = fist+  { iname    = "tip"+  , ifreq    = [(S_TIP, 1)]+  , icount   = 1+  , iverbHit = "poke"+  , idamage  = 2 `d` 1   , idesc    = ""   }-eye2 = eye 2-eye3 = eye 3-eye4 = eye 4-eye5 = eye 5---- * Human weapon organs- fist = ItemKind-  { isymbol  = '%'+  { isymbol  = toContentSymbol ','   , iname    = "fist"-  , ifreq    = [("fist", 100)]-  , iflavour = zipPlain [BrRed]+  , ifreq    = [(S_FIST, 1)]+  , iflavour = zipPlain [Red]   , icount   = 2   , irarity  = [(1, 1)]   , iverbHit = "punch"   , iweight  = 2000-  , iaspects = []-  , ieffects = [Hurt (4 * d 1)]-  , ifeature = [Durable, EqpSlot EqpSlotWeapon "", Identified]-  , idesc    = ""+  , idamage  = 4 `d` 1+  , iaspects = [SetFlag Durable, SetFlag Meleeable]+  , ieffects = []+  , idesc    = "Simple but effective."   , ikit     = []   } foot = fist   { iname    = "foot"-  , ifreq    = [("foot", 50)]-  , icount   = 2+  , ifreq    = [(S_FOOT, 1)]   , iverbHit = "kick"-  , ieffects = [Hurt (4 * d 1)]-  , idesc    = ""-  }---- * Universal weapon organs--claw = fist-  { iname    = "claw"-  , ifreq    = [("claw", 50)]-  , icount   = 2  -- even if more, only the fore claws used for fighting-  , iverbHit = "slash"-  , ieffects = [Hurt (6 * d 1)]-  , idesc    = ""+  , idamage  = 4 `d` 1+  , idesc    = "A weapon you can still use if disarmed."+                 -- great example of tutorial hints inside a flavourful text   } smallClaw = fist   { iname    = "small claw"-  , ifreq    = [("small claw", 50)]-  , icount   = 2+  , ifreq    = [(S_SMALL_CLAW, 1)]   , iverbHit = "slash"-  , ieffects = [Hurt (3 * d 1)]-  , idesc    = ""+  , idamage  = 2 `d` 1+  , idesc    = "A pearly spike."   } snout = fist   { iname    = "snout"-  , ifreq    = [("snout", 10)]+  , ifreq    = [(S_SNOUT, 1)]+  , icount   = 1   , iverbHit = "bite"-  , ieffects = [Hurt (2 * d 1)]-  , idesc    = ""+  , idamage  = 2 `d` 1+  , idesc    = "Sensitive and wide-nostrilled."   }+smallJaw = fist+  { iname    = "small jaw"+  , ifreq    = [(S_SMALL_JAW, 1)]+  , icount   = 1+  , iverbHit = "rip"+  , idamage  = 3 `d` 1+  , idesc    = "Filled with small, even teeth."+  }++-- * Cooldown melee damage organs without effects++tentacle = fist  -- two copies only+  { iname    = "tentacle"+  , ifreq    = [(S_TENTACLE, 1)]+  , iverbHit = "slap"+  , idamage  = 4 `d` 1+  , iaspects = Timeout 3  -- minimal timeout that lets other organs show+               : iaspects fist+  , idesc    = "Damp and dextrous."+  } jaw = fist   { iname    = "jaw"-  , ifreq    = [("jaw", 20)]+  , ifreq    = [(S_JAW, 1)]   , icount   = 1   , iverbHit = "rip"-  , ieffects = [Hurt (5 * d 1)]-  , idesc    = ""+  , idamage  = 5 `d` 1+  , iaspects = Timeout (2 + 1 `d` 2)  -- no effect, but limit raw damage+               : iaspects fist+  , idesc    = "Delivers a powerful bite."   }+horn = fist+  { iname    = "horn"+  , ifreq    = [(S_HORN, 1)]+  , iverbHit = "impale"+  , idamage  = 5 `d` 1+  , iaspects = [ Timeout 7  -- no effect, but limit raw damage; two copies+               , AddSkill SkArmorMelee 10 ]  -- bonus doubled+               ++ iaspects fist+  , idesc    = "Sharp and long, for defence or attack."+  } largeJaw = fist   { iname    = "large jaw"-  , ifreq    = [("large jaw", 100)]+  , ifreq    = [(S_LARGE_JAW, 1)]   , icount   = 1   , iverbHit = "crush"-  , ieffects = [Hurt (12 * d 1)]-  , idesc    = ""-  }-tooth = fist-  { iname    = "tooth"-  , ifreq    = [("tooth", 20)]-  , icount   = 3-  , iverbHit = "nail"-  , ieffects = [Hurt (3 * d 1)]-  , idesc    = ""+  , idamage  = 10 `d` 1+  , iaspects = Timeout (2 + 1 `d` 2)  -- no effect, but limit raw damage+               : iaspects fist+  , idesc    = "Enough to swallow anything in a single gulp."   } --- * Monster weapon organs+-- * Direct damage organs with effects -tentacle = fist-  { iname    = "tentacle"-  , ifreq    = [("tentacle", 50)]-  , icount   = 4-  , iverbHit = "slap"-  , ieffects = [Hurt (4 * d 1)]-  , idesc    = ""-  }-lash = fist-  { iname    = "lash"-  , ifreq    = [("lash", 100)]+beeSting = fist+  { isymbol  = symbolWand+  , iname    = "bee sting"+  , ifreq    = [(S_BEE_STING, 1)]   , icount   = 1-  , iverbHit = "lash"-  , ieffects = [Hurt (4 * d 1)]-  , idesc    = ""+  , iverbHit = "sting"+  , idamage  = 0+  , iaspects = [ AddSkill SkArmorMelee 200, AddSkill SkArmorRanged 45+               , SetFlag Meleeable ]  -- not Durable+  , ieffects = [Paralyze 6, RefillHP 4]+                 -- no special message when runs out, because it's 1 copy+  , idesc    = "Painful, but beneficial."   }-noseTip = fist-  { iname    = "tip"-  , ifreq    = [("nose tip", 50)]+sting = fist+  { isymbol  = symbolWand+  , iname    = "sting"+  , ifreq    = [(S_STING, 1)]   , icount   = 1-  , iverbHit = "poke"-  , ieffects = [Hurt (2 * d 1)]-  , idesc    = ""+  , iverbHit = "inject"+  , idamage  = 1 `d` 1+  , iaspects = [Timeout $ 10 - 1 `dL` 4, AddSkill SkHurtMelee 40]+               ++ iaspects fist+  , ieffects = [toOrganBad S_RETAINING (3 + 1 `d` 3)]+  , idesc    = "Painful, debilitating and harmful."   } lip = fist   { iname    = "lip"-  , ifreq    = [("lip", 10)]-  , icount   = 2+  , ifreq    = [(S_LIP, 1)]+  , icount   = 1   , iverbHit = "lap"-  , ieffects = [Hurt (2 * d 1)]  -- TODO: decrease Hurt, but use+  , idamage  = 1 `d` 1+  , iaspects = Timeout (3 + 1 `d` 2)+               : iaspects fist+  , ieffects = [toOrganBad S_WEAKENED (2 + 1 `dL` 3)]   , idesc    = ""   }---- * Special weapon organs--thorn = fist-  { iname    = "thorn"-  , ifreq    = [("thorn", 100)]-  , icount   = 7-  , iverbHit = "impale"-  , ieffects = [Hurt (2 * d 1)]-  , idesc    = ""+venomTooth = fist+  { isymbol  = symbolWand+  , iname    = "venom tooth"+  , ifreq    = [(S_VENOM_TOOTH, 1)]+  , iverbHit = "bite"+  , idamage  = 1 `d` 1+  , iaspects = Timeout (7 - 1 `dL` 3)+               : iaspects fist+  , ieffects = [toOrganBad S_SLOWED (3 + 1 `d` 3)]+  , idesc    = "A chilling numbness spreads from its bite."   }-fissure = fist-  { iname    = "fissure"-  , ifreq    = [("fissure", 100)]-  , icount   = 2-  , iverbHit = "hiss at"-  , ieffects = [Burn 1]-  , idesc    = ""+hookedClaw = fist+  { isymbol  = symbolWand+  , iname    = "hooked claw"+  , ifreq    = [(S_HOOKED_CLAW, 1)]+  , icount   = 2  -- even if more, only the fore claws used for fighting+  , iverbHit = "hook"+  , idamage  = 2 `d` 1+  , iaspects = Timeout (12 - 1 `dL` 3)+               : iaspects fist+  , ieffects = [toOrganBad S_SLOWED 2]+  , idesc    = "A curved talon."   }-sting = fist-  { iname    = "sting"-  , ifreq    = [("sting", 100)]+screechingBeak = fist+  { isymbol  = symbolWand+  , iname    = "screeching beak"+  , ifreq    = [(S_SCREECHING_BEAK, 1)]   , icount   = 1-  , iverbHit = "sting"-  , ieffects = [Burn 1, Paralyze 2]-  , idesc    = ""+  , iverbHit = "peck"+  , idamage  = 3 `d` 1+  , iaspects = Timeout (7 - 1 `dL` 3)+               : iaspects fist+  , ieffects = [Summon SCAVENGER $ 1 `dL` 3]+  , idesc    = "Both a weapon and a beacon, calling more scavengers to the meal."   }-venomTooth = fist-  { iname    = "venom tooth"-  , ifreq    = [("venom tooth", 100)]-  , icount   = 2-  , iverbHit = "bite"-  , ieffects = [Hurt (3 * d 1), Paralyze 3]+antler = fist+  { isymbol  = symbolWand+  , iname    = "antler"+  , ifreq    = [(S_ANTLER, 1)]+  , iverbHit = "ram"+  , idamage  = 4 `d` 1+  , iaspects = [ Timeout $ 3 + (1 `d` 3) * 3+               , AddSkill SkArmorMelee 10 ]  -- bonus doubled+               ++ iaspects fist+  , ieffects = [PushActor (ThrowMod 100 50 1)]  -- 1 step, slow   , idesc    = ""   }-venomFang = fist-  { iname    = "venom fang"-  , ifreq    = [("venom fang", 100)]-  , icount   = 2-  , iverbHit = "bite"-  , ieffects = [Hurt (3 * d 1)]  -- TODO: +12 damage or poison effect-  , idesc    = ""+rhinoHorn = fist+  { isymbol  = symbolWand+  , iname    = "ugly horn"  -- made of keratin, unlike real horns+  , ifreq    = [(S_RHINO_HORN, 1)]+  , icount   = 1  -- single, unlike real horns+  , iverbHit = "gore"+  , idamage  = 5 `d` 1+  , iaspects = [Timeout 5, AddSkill SkHurtMelee 20]+               ++ iaspects fist+  , ieffects = [Impress, Yell]  -- the owner is a mid-boss, after all+  , idesc    = "Very solid, considering it has the same composition as fingernails."   } largeTail = fist-  { iname    = "large tail"-  , ifreq    = [("large tail", 50)]+  { isymbol  = symbolWand+  , iname    = "large tail"+  , ifreq    = [(S_LARGE_TAIL, 1)]   , icount   = 1   , iverbHit = "knock"-  , ieffects = [Hurt (8 * d 1), PushActor (ThrowMod 400 25)]+  , idamage  = 7 `d` 1+  , iaspects = [Timeout $ 2 + 1 `d` 2, AddSkill SkHurtMelee 20]+               ++ iaspects fist+                 -- timeout higher, lest they regain push before closing again+  , ieffects = [PushActor (ThrowMod 200 50 1)]  -- 1 step, fast+  , idesc    = "Almost as long as the trunk."+  }+hugeTail = largeTail+  { isymbol  = symbolWand+  , iname    = "huge tail"+  , ifreq    = [(S_HUGE_TAIL, 1)]+  , iverbHit = "upend"+  , iaspects = [Timeout $ 3 + 1 `d` 2, AddSkill SkHurtMelee 20]+               ++ iaspects fist+                 -- timeout higher, lest they regain push before closing again+  , ieffects = [PushActor (ThrowMod 400 50 1)]  -- 2 steps, fast+  , idesc    = "Slow but immensely heavy."+  }++-- * Melee weapons without direct damage++venomFang = fist+  { isymbol  = symbolWand+  , iname    = "venom fang"+  , ifreq    = [(S_VENOM_FANG, 1)]+  , iverbHit = "bite"+  , idamage  = 0+  , iaspects = Timeout (10 - 1 `dL` 5)+               : iaspects fist+  , ieffects = [toOrganNoTimer S_POISONED]+  , idesc    = "Dripping with deadly venom."+  }++-- * Special melee weapons++sulfurFissure = boilingFissure+  { iname    = "fissure"+  , ifreq    = [(S_SULFUR_FISSURE, 1)]+  , icount   = 2 + 1 `d` 2+  , idamage  = 0  -- heal not via (negative) idamage, for armour would block it+  , iaspects = SetFlag Benign : iaspects boilingFissure+  , ieffects = [ RefillHP 5+               , VerbNoLonger "run out of the healing fumes" "."]   , idesc    = ""   }-pupil = fist-  { iname    = "pupil"-  , ifreq    = [("pupil", 100)]-  , icount   = 1-  , iverbHit = "gaze at"-  , iaspects = [AddSight 7]-  , ieffects = [Hurt (4 * d 1), Paralyze 1]  -- TODO: decrease Hurt, but use+boilingFissure = fist+  { isymbol  = symbolWand+  , iname    = "fissure"+  , ifreq    = [(S_BOILING_FISSURE, 1)]+  , icount   = 5 + 1 `d` 5+  , iverbHit = "hiss at"+  , idamage  = 1 `d` 1+  , iaspects = [ AddSkill SkHurtMelee 20  -- decreasing as count decreases+               , SetFlag Meleeable ]  -- not Durable+  , ieffects = [ DropItem 1 1 COrgan CONDITION  -- useful; limited+               , VerbNoLonger "widen the crack, releasing pressure" "."]+  , idesc    = "A deep crack to the underworld."+  }+arsenicFissure = boilingFissure+  { iname    = "fissure"+  , ifreq    = [(S_ARSENIC_FISSURE, 1)]+  , icount   = 3 + 1 `d` 3+  , idamage  = 2 `d` 1+  , ieffects = [ toOrganBad S_PARSIMONIOUS (5 + 1 `d` 3)+               -- weaken/poison, impacting intellectual abilities first+               , VerbNoLonger "stop exuding stupefying vapours" "."]   , idesc    = ""   }  -- * Armor organs -armoredSkin = fist-  { iname    = "armored skin"-  , ifreq    = [("armored skin", 100)]+armoredSkin = ItemKind+  { isymbol  = toContentSymbol ','+  , iname    = "armored skin"+  , ifreq    = [(S_ARMORED_SKIN, 1)]+  , iflavour = zipPlain [Red]   , icount   = 1+  , irarity  = [(1, 1)]   , iverbHit = "bash"-  , iaspects = [AddArmorMelee 33, AddArmorRanged 33]+  , iweight  = 2000+  , idamage  = 0+  , iaspects = [ AddSkill SkArmorMelee 30, AddSkill SkArmorRanged 15+               , SetFlag Durable ]   , ieffects = []-  , ifeature = [Durable, Identified]+  , idesc    = "Homemade armour is just as good."  -- hmm, it may get confused with leather armor jackets, etc.+  , ikit     = []+  }+bark = armoredSkin+  { iname    = "bark"+  , ifreq    = [(S_BARK, 1)]   , idesc    = ""   }  -- * Sense organs -nostril = fist+eye :: Int -> GroupName ItemKind -> ItemKind+eye n grp = armoredSkin+  { iname    = "eye"+  , ifreq    = [(grp, 1)]+  , icount   = 2+  , iverbHit = "glare at"+  , iaspects = [ AddSkill SkSight (intToDice n)+               , SetFlag Durable ]+  , idesc    = "A piercing stare."+  }+eye3 = eye 3 S_EYE_3+eye6 = eye 6 S_EYE_6+eye8 = eye 8 S_EYE_8+vision :: Int -> GroupName ItemKind -> ItemKind+vision n grp = armoredSkin+  { iname    = "vision"+  , ifreq    = [(grp, 1)]+  , iverbHit = "visualize"+  , iaspects = [ AddSkill SkSight (intToDice n)+               , SetFlag Durable ]+  , idesc    = ""+  }+vision6 = vision 6 S_VISION_6+vision12 = vision 12 S_VISION_12+vision16 = vision 16 S_VISION_16+nostril = armoredSkin   { iname    = "nostril"-  , ifreq    = [("nostril", 100)]+  , ifreq    = [(S_NOSTRIL, 1)]   , icount   = 2   , iverbHit = "snuff"-  , iaspects = [AddSmell 1]-  , ieffects = []-  , ifeature = [Durable, Identified]+  , iaspects = [ AddSkill SkSmell 1  -- times 2, from icount+               , SetFlag Durable ]   , idesc    = ""   }+ear :: Int -> GroupName ItemKind -> ItemKind+ear n grp = armoredSkin+  { iname    = "ear"+  , ifreq    = [(grp, 1)]+  , icount   = 2+  , iverbHit = "overhear"+  , iaspects = [ AddSkill SkHearing (intToDice n)+               , SetFlag Durable ]+  , idesc    = ""+  }+ear3 = ear 3 S_EAR_3+ear6 = ear 6 S_EAR_6+ear8 = ear 8 S_EAR_8  -- * Assorted -vent = fist-  { iname    = "vent"-  , ifreq    = [("vent", 100)]-  , icount   = 1+rattleOrgan = armoredSkin+  { iname    = "rattle"+  , ifreq    = [(S_RATLLE, 1)]+  , iverbHit = "announce"+  , iaspects = [ Timeout $ 10 + (1 `d` 3) * 10  -- long, to limit spam+               , SetFlag Periodic, SetFlag Durable ]+  , ieffects = [Yell, RefillCalm 5]+  , idesc    = ""+  }+insectMortality = armoredSkin+  { iname    = "insect mortality"+  , ifreq    = [(S_INSECT_MORTALITY, 1)]+  , iverbHit = "age"+  , iaspects = [ AddSkill SkAggression 2  -- try to attack before you die+               , Timeout $ 30 + (1 `d` 3) * 10  -- die very slowly+               , SetFlag Periodic, SetFlag Durable ]+  , ieffects = [RefillHP (-1), Yell]+  , idesc    = ""+  }+sapientBrain = armoredSkin+  { iname    = "sapient brain"+  , ifreq    = [(S_SAPIENT_BRAIN, 1)]+  , iverbHit = "outbrain"+  , iaspects = [AddSkill sk 1 | sk <- [SkMove .. SkApply]]+               ++ [AddSkill SkMove 4]  -- can move at once when waking up+               ++ [AddSkill SkAlter 4]  -- can use all stairs; dig rubble, ice+               ++ [AddSkill SkWait 2]  -- can brace and sleep+               ++ [AddSkill SkApply 1]  -- can use most items, not just foods+               ++ [SetFlag Durable]+  , idesc    = ""+  }+animalBrain = armoredSkin+  { iname    = "animal brain"+  , ifreq    = [(S_ANIMAL_BRAIN, 1)]+  , iverbHit = "blank"+  , iaspects = [AddSkill sk 1 | sk <- [SkMove .. SkApply]]+               ++ [AddSkill SkMove 4]  -- can move at once when waking up+               ++ [AddSkill SkAlter 2]  -- can use normal stairs; can't dig+               ++ [AddSkill SkWait 2]  -- can brace and sleep+               -- No @SkApply@ bonus, so can only apply foods. Note, however,+               -- that AI doesn't risk applying unIded items, so in early+               -- game animals won't eat anything.+               ++ [AddSkill SkDisplace (-1)]  -- no melee tactics+               ++ [AddSkill SkMoveItem (-1)]  -- no item gathering+               ++ [AddSkill SkProject (-1)]  -- nor item flinging+               ++ [SetFlag Durable]+  , idesc    = ""+  }+speedGland :: Int -> GroupName ItemKind -> ItemKind+speedGland n grp = armoredSkin+  { isymbol  = symbolWand+  , iname    = "speed gland"+  , ifreq    = [(grp, 1)]+  , iverbHit = "spit at"+  , iaspects = [ Timeout $ intToDice (100 `div` n)+               , AddSkill SkSpeed $ intToDice n+               , SetFlag Periodic, SetFlag Durable ]+  , ieffects = [RefillHP 1]+  , idesc    = ""+  }+speedGland5 = speedGland 5 S_SPEED_GLAND_5+speedGland10 = speedGland 10 S_SPEED_GLAND_10+scentGland = armoredSkin+  { isymbol  = symbolWand+  , iname    = "scent gland"+  , ifreq    = [(S_SCENT_GLAND, 1)]+  , icount   = 10 + 1 `d` 3  -- runs out+  , iverbHit = "spray at"+  , iaspects = [ Timeout $ (1 `d` 3) * 10+               , SetFlag Periodic, SetFlag Fragile ]  -- not Durable+  , ieffects = [ VerbNoLonger "look spent" "."+               , ApplyPerfume+               , Explode S_DISTRESSING_ODOR ]+                   -- keep explosion at the end to avoid the ambiguity of+                   -- "of ([foo explosion] of [bar])"+  , idesc    = ""+  }+sulfurVent = armoredSkin+  { isymbol  = toContentSymbol 'v'+  , iname    = "vent"+  , ifreq    = [(S_SULFUR_VENT, 1)]+  , iflavour = zipPlain [BrYellow]   , iverbHit = "menace"-  , iaspects = [Periodic $ 1 + d 2]-  , ieffects = [Explode "boiling water"]-  , ifeature = [Durable, Identified]+  , iaspects = [ Timeout $ (2 + 1 `d` 3) * 5+               , SetFlag Periodic, SetFlag Durable ]+  , ieffects = [RefillHP 2, Explode S_DENSE_SHOWER]+  , idesc    = ""+  }+boilingVent = armoredSkin+  { isymbol  = toContentSymbol 'v'+  , iname    = "vent"+  , ifreq    = [(S_BOILING_VENT, 1)]+  , iflavour = zipPlain [Blue]+  , iverbHit = "menace"+  , iaspects = [ Timeout $ (2 + 1 `d` 3) * 5+               , SetFlag Periodic, SetFlag Durable ]+  , ieffects = [RefillHP 2, Explode S_BOILING_WATER]+  , idesc    = ""+  }+arsenicVent = armoredSkin+  { isymbol  = toContentSymbol 'v'+  , iname    = "vent"+  , ifreq    = [(S_ARSENIC_VENT, 1)]+  , iflavour = zipPlain [Cyan]+  , iverbHit = "menace"+  , iaspects = [ Timeout $ (2 + 1 `d` 3) * 5+               , SetFlag Periodic, SetFlag Durable ]+  , ieffects = [RefillHP 2, Explode S_SPARSE_SHOWER]+  , idesc    = ""+  }++-- * Special++bonusHP = armoredSkin+  { isymbol  = toContentSymbol 'H'  -- '+' reserved for conditions+  , iname    = "extra HP"+  , ifreq    = [(S_BONUS_HP, 1)]+  , iflavour = zipPlain [BrBlue]+  , iverbHit = "intimidate"+  , iweight  = 0+  , iaspects = [AddSkill SkMaxHP 1]+  , idesc    = "Growing up in a privileged background gave you the training and the discrete garment accessories that improve your posture and resilience."+  }+braced = armoredSkin+  { isymbol  = toContentSymbol 'B'+  , iname    = "braced"+  , ifreq    = [(S_BRACED, 1)]+  , iflavour = zipPlain [BrGreen]+  , iverbHit = "brace"+  , iweight  = 0+  , iaspects = [ AddSkill SkArmorMelee 50, AddSkill SkArmorRanged 25+               , AddSkill SkHearing 10+               , SetFlag Condition ] -- hack: display as condition+  , idesc    = "Apart of increased resilience to attacks, being braced protects from displacement by foes and other forms of forced translocation, e.g., pushing or pulling."+  }+asleep = armoredSkin+  { isymbol  = toContentSymbol 'S'+  , iname    = "asleep"+  , ifreq    = [(S_ASLEEP, 1)]+  , iflavour = zipPlain [BrGreen]  -- regenerates HP (very slowly)+  , icount   = 5+  , iverbHit = "slay"+  , iweight  = 0+  , iaspects = [AddSkill sk (-1) | sk <- [SkMove .. SkApply]]+               ++ [ AddSkill SkMelee 1, AddSkill SkAlter 1, AddSkill SkWait 1+                  , AddSkill SkSight (-3), AddSkill SkArmorMelee (-10)+                  , SetFlag Condition ]  -- hack: display as condition+  , idesc    = "Sleep helps to regain health, albeit extremely slowly. Being asleep makes you vulnerable, with gradually diminishing effects as the slumber wears off over several turns. Any non-idle action, not only combat but even yawning or stretching removes a sizable portion of the sleepiness."+  }+impressed = armoredSkin+  { isymbol  = toContentSymbol 'I'+  , iname    = "impressed"  -- keep the same as in @ifreq@, to simplify code+  , ifreq    = [(S_IMPRESSED, 1), (CONDITION, 1)]+  , iflavour = zipPlain [BrRed]+  , iverbHit = "confuse"+  , iweight  = 0+  , iaspects = [ AddSkill SkMaxCalm (-1)  -- to help player notice on HUD+                                          -- and to count as bad condition+               , SetFlag Fragile  -- to announce "no longer" only when+                                  -- all copies gone+               , SetFlag Condition ]  -- this is really a condition,+                                      -- just not a timed condition+  , ieffects = [ OnSmash $ verbMsgLess "impressed"+               , OnSmash $ verbMsgNoLonger "impressed" ]+                   -- not periodic, so no wear each turn, so only @OnSmash@+  , idesc    = "Being impressed by one's adversary sounds like fun, but on battlefield it equals treason. Almost. Throw in depleted battle calm and it leads to mindless desertion outright."+  }++-- * LH-specific++tooth = fist+  { iname    = "tooth"+  , ifreq    = [(S_TOOTH, 1)]+  , icount   = 3+  , iverbHit = "nail"+  , idamage  = 2 `d` 1+  , idesc    = ""+  }+lash = fist+  { iname    = "lash"+  , ifreq    = [(S_LASH, 1)]+  , icount   = 1+  , iverbHit = "lash"+  , idamage  = 3 `d` 1+  , idesc    = ""+  }+torsionRight = fist+  { iname    = "right torsion"+  , ifreq    = [(S_RIGHT_TORSION, 1)]+  , icount   = 1+  , iverbHit = "twist"+  , idamage  = 13 `d` 1+  , iaspects = [Timeout $ 5 + 1 `d` 5, AddSkill SkHurtMelee 20]+               ++ iaspects fist+  , ieffects = [toOrganBad S_SLOWED (3 + 1 `d` 3)]+  , idesc    = ""+  }+torsionLeft = fist+  { iname    = "left torsion"+  , ifreq    = [(S_LEFT_TORSION, 1)]+  , icount   = 1+  , iverbHit = "untwist"+  , idamage  = 13 `d` 1+  , iaspects = [Timeout $ 5 + 1 `d` 5, AddSkill SkHurtMelee 20]+               ++ iaspects fist+  , ieffects = [toOrganBad S_WEAKENED (3 + 1 `d` 3)]+  , idesc    = ""+  }+pupil = fist+  { iname    = "pupil"+  , ifreq    = [(S_PUPIL, 1)]+  , icount   = 1+  , iverbHit = "gaze at"+  , idamage  = 1 `d` 1+  , iaspects = [AddSkill SkSight 12, Timeout 12]+               ++ iaspects fist+  , ieffects = [DropItem 1 maxBound COrgan CONDITION, RefillCalm (-10)]+                 -- can be useful for the player, but Calm drain is a risk   , idesc    = ""   }
− GameDefinition/Content/ItemKindShrapnel.hs 
@@ -1,239 +0,0 @@--- | Shrapnel definitions.-module Content.ItemKindShrapnel ( shrapnels ) where--import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Dice-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Content.ItemKind--shrapnels :: [ItemKind]-shrapnels =-  [fragrance, pheromone, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, mistHealing, mistWounding, distortion, waste, burningOil2, burningOil3, burningOil4, explosionBlast10, explosionBlast20, glassPiece, smoke, boilingWater, glue]--fragrance,    pheromone, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, mistHealing, mistWounding, distortion, waste, burningOil2, burningOil3, burningOil4, explosionBlast10, explosionBlast20, glassPiece, smoke, boilingWater, glue :: ItemKind---- * Parameterized shrapnel--burningOil :: Int -> ItemKind-burningOil n = ItemKind-  { isymbol  = '*'-  , iname    = "burning oil"-  , ifreq    = [("burning oil" <+> tshow n, 1)]-  , iflavour = zipFancy [BrYellow]-  , icount   = intToDice (n * 4)-  , irarity  = [(1, 1)]-  , iverbHit = "burn"-  , iweight  = 1-  , iaspects = [AddLight 2]-  , ieffects = [ Burn (n `div` 2)-               , Paralyze (intToDice $ n `div` 2) ]  -- tripping on oil-  , ifeature = [ toVelocity (min 100 $ n * 7)-               , Fragile, Identified ]-  , idesc    = "Sticky oil, burning brightly."-  , ikit     = []-  }-burningOil2 = burningOil 2-burningOil3 = burningOil 3-burningOil4 = burningOil 4-explosionBlast :: Int -> ItemKind-explosionBlast n = ItemKind-  { isymbol  = '*'-  , iname    = "explosion blast"-  , ifreq    = [("explosion blast" <+> tshow n, 1)]-  , iflavour = zipPlain [BrRed]-  , icount   = 12  -- strong, but few, so not always hits target-  , irarity  = [(1, 1)]-  , iverbHit = "tear apart"-  , iweight  = 1-  , iaspects = [AddLight $ intToDice n]-  , ieffects = [RefillHP (- n `div` 2), DropBestWeapon]-  , ifeature = [Fragile, toLinger 10, Identified]-  , idesc    = ""-  , ikit     = []-  }-explosionBlast10 = explosionBlast 10-explosionBlast20 = explosionBlast 20-firecracker :: Int -> ItemKind-firecracker n = ItemKind-  { isymbol  = '*'-  , iname    = "firecracker"-  , ifreq    = [("firecracker" <+> tshow n, 1)]-  , iflavour = zipPlain [stdCol !! (n `mod` length stdCol)]-  , icount   = intToDice $ 2 * n-  , irarity  = [(1, 1)]-  , iverbHit = "crack"-  , iweight  = 1-  , iaspects = [AddLight $ intToDice $ n `div` 2]-  , ieffects = [Burn 1, Explode $ "firecracker" <+> tshow (n - 1)]-  , ifeature = [ ToThrow $ ThrowMod (n * 10) 20-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-firecracker7 = firecracker 7-firecracker6 = firecracker 6-firecracker5 = firecracker 5-firecracker4 = firecracker 4-firecracker3 = firecracker 3-firecracker2 = firecracker 2---- * Assorted--fragrance = ItemKind-  { isymbol  = '\''-  , iname    = "fragrance"-  , ifreq    = [("fragrance", 1)]-  , iflavour = zipFancy [Magenta]-  , icount   = 15-  , irarity  = [(1, 1)]-  , iverbHit = "engulf"-  , iweight  = 1-  , iaspects = []-  , ieffects = [Impress]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-pheromone = ItemKind-  { isymbol  = '\''-  , iname    = "musky whiff"-  , ifreq    = [("pheromone", 1)]-  , iflavour = zipFancy [BrMagenta]-  , icount   = 8-  , irarity  = [(1, 1)]-  , iverbHit = "tempt"-  , iweight  = 1-  , iaspects = []-  , ieffects = [Dominate]-  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-mistHealing = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("healing mist", 1)]-  , iflavour = zipFancy [White]-  , icount   = 11-  , irarity  = [(1, 1)]-  , iverbHit = "revitalize"-  , iweight  = 1-  , iaspects = [AddLight 1]-  , ieffects = [RefillHP 2]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-mistWounding = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("wounding mist", 1)]-  , iflavour = zipFancy [White]-  , icount   = 13-  , irarity  = [(1, 1)]-  , iverbHit = "devitalize"-  , iweight  = 1-  , iaspects = []-  , ieffects = [RefillHP (-2)]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-distortion = ItemKind-  { isymbol  = 'v'-  , iname    = "vortex"-  , ifreq    = [("distortion", 1)]-  , iflavour = zipFancy [White]-  , icount   = 4-  , irarity  = [(1, 1)]-  , iverbHit = "engulf"-  , iweight  = 1-  , iaspects = []-  , ieffects = [Teleport $ 15 + d 10]-  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-waste = ItemKind-  { isymbol  = '*'-  , iname    = "waste"-  , ifreq    = [("waste", 1)]-  , iflavour = zipPlain [Brown]-  , icount   = 10-  , irarity  = [(1, 1)]-  , iverbHit = "splosh"-  , iweight  = 50-  , iaspects = []-  , ieffects = [RefillHP (-1)]-  , ifeature = [ ToThrow $ ThrowMod 28 50-               , Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-glassPiece = ItemKind  -- when blowing up windows-  { isymbol  = '*'-  , iname    = "glass piece"-  , ifreq    = [("glass piece", 1)]-  , iflavour = zipPlain [BrBlue]-  , icount   = 17-  , irarity  = [(1, 1)]-  , iverbHit = "cut"-  , iweight  = 10-  , iaspects = []-  , ieffects = [Hurt (1 * d 1)]-  , ifeature = [toLinger 20, Fragile, Identified]-  , idesc    = ""-  , ikit     = []-  }-smoke = ItemKind  -- when stuff burns out-  { isymbol  = '\''-  , iname    = "smoke"-  , ifreq    = [("smoke", 1), ("firecracker 1", 1)]-  , iflavour = zipPlain [BrBlack]-  , icount   = 19-  , irarity  = [(1, 1)]-  , iverbHit = "choke"-  , iweight  = 1-  , iaspects = []-  , ieffects = []-  , ifeature = [ toVelocity 21, Fragile, Identified ]-  , idesc    = ""-  , ikit     = []-  }-boilingWater = ItemKind-  { isymbol  = '*'-  , iname    = "boiling water"-  , ifreq    = [("boiling water", 1)]-  , iflavour = zipPlain [BrWhite]-  , icount   = 9-  , irarity  = [(1, 1)]-  , iverbHit = "boil"-  , iweight  = 5-  , iaspects = []-  , ieffects = [Burn 1]-  , ifeature = [toVelocity 50, Fragile, Identified]-  , idesc    = ""-  , ikit     = []-  }-glue = ItemKind-  { isymbol  = '*'-  , iname    = "hoof glue"-  , ifreq    = [("glue", 1)]-  , iflavour = zipPlain [BrYellow]-  , icount   = 14-  , irarity  = [(1, 1)]-  , iverbHit = "glue"-  , iweight  = 20-  , iaspects = []-  , ieffects = [Paralyze (3 + d 3)]-  , ifeature = [toVelocity 40, Fragile, Identified]-  , idesc    = ""-  , ikit     = []-  }
+ GameDefinition/Content/ItemKindTemporary.hs view
@@ -0,0 +1,212 @@+-- | Temporary pseudo-organ (condition) definitions.+module Content.ItemKindTemporary+  ( -- * Group name patterns+    pattern S_IMMOBILE, pattern S_PACIFIED, pattern S_IRREPLACEABLE, pattern S_RETAINING, pattern S_IMPATIENT, pattern S_DISPOSSESSED, pattern S_WITHHOLDING, pattern S_PARSIMONIOUS+  , pattern S_MORE_MOBILE, pattern S_MORE_COMBATIVE, pattern S_MORE_DISPLACING, pattern S_MORE_MODIFYING, pattern S_MORE_PATIENT, pattern S_MORE_TIDY, pattern S_MORE_PROJECTING, pattern S_MORE_PRACTICAL+  , pattern S_STRENGTHENED, pattern S_WEAKENED, pattern S_PROTECTED_FROM_MELEE, pattern S_PROTECTED_FROM_RANGED, pattern S_DEFENSELESS, pattern S_RESOLUTE, pattern S_HASTED, pattern S_SLOWED, pattern S_FAR_SIGHTED, pattern S_BLIND, pattern S_KEEN_SMELLING, pattern S_FOUL_SMELLING, pattern S_ROSE_SMELLING, pattern S_RANGED_DEFLECTING, pattern S_MELEE_DEFLECTING, pattern S_SHINY_EYED, pattern S_DEAFENED, pattern S_DEAF, pattern S_DRUNK, pattern S_FRENZIED, pattern S_REGENERATING, pattern S_POISONED, pattern S_SLOW_RESISTANT, pattern S_POISON_RESISTANT+  , temporariesGNSingleton, noStatGN, bonusStatGN+  , -- * Content+    temporaries+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Core.Dice+import Game.LambdaHack.Definition.Ability+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal+import Game.LambdaHack.Definition.Flavour++-- * Group name patterns++noStatGN :: [GroupName ItemKind]+noStatGN =+       [S_IMMOBILE, S_PACIFIED, S_IRREPLACEABLE, S_RETAINING, S_IMPATIENT, S_DISPOSSESSED, S_WITHHOLDING, S_PARSIMONIOUS]++bonusStatGN :: [GroupName ItemKind]+bonusStatGN =+       [S_MORE_MOBILE, S_MORE_COMBATIVE, S_MORE_DISPLACING, S_MORE_MODIFYING, S_MORE_PATIENT, S_MORE_TIDY, S_MORE_PROJECTING, S_MORE_PRACTICAL]++temporariesGNSingleton :: [GroupName ItemKind]+temporariesGNSingleton =+       [S_STRENGTHENED, S_WEAKENED, S_PROTECTED_FROM_MELEE, S_PROTECTED_FROM_RANGED, S_DEFENSELESS, S_RESOLUTE, S_HASTED, S_SLOWED, S_FAR_SIGHTED, S_BLIND, S_KEEN_SMELLING, S_FOUL_SMELLING, S_ROSE_SMELLING, S_RANGED_DEFLECTING, S_MELEE_DEFLECTING, S_SHINY_EYED, S_DEAFENED, S_DEAF, S_DRUNK, S_FRENZIED, S_REGENERATING, S_POISONED, S_SLOW_RESISTANT, S_POISON_RESISTANT]+    ++ noStatGN ++ bonusStatGN++pattern S_IMMOBILE, S_PACIFIED, S_IRREPLACEABLE, S_RETAINING, S_IMPATIENT, S_DISPOSSESSED, S_WITHHOLDING, S_PARSIMONIOUS :: GroupName ItemKind++pattern S_MORE_MOBILE, S_MORE_COMBATIVE, S_MORE_DISPLACING, S_MORE_MODIFYING, S_MORE_PATIENT, S_MORE_TIDY, S_MORE_PROJECTING, S_MORE_PRACTICAL :: GroupName ItemKind++pattern S_STRENGTHENED, S_WEAKENED, S_PROTECTED_FROM_MELEE, S_PROTECTED_FROM_RANGED, S_DEFENSELESS, S_RESOLUTE, S_HASTED, S_SLOWED, S_FAR_SIGHTED, S_BLIND, S_KEEN_SMELLING, S_FOUL_SMELLING, S_ROSE_SMELLING, S_RANGED_DEFLECTING, S_MELEE_DEFLECTING, S_SHINY_EYED, S_DEAFENED, S_DEAF, S_DRUNK, S_FRENZIED, S_REGENERATING, S_POISONED, S_SLOW_RESISTANT, S_POISON_RESISTANT :: GroupName ItemKind++pattern S_STRENGTHENED = GroupName "strengthened"+pattern S_WEAKENED = GroupName "weakened"+pattern S_PROTECTED_FROM_MELEE = GroupName "protected from melee"+pattern S_PROTECTED_FROM_RANGED = GroupName "protected from ranged"+pattern S_DEFENSELESS = GroupName "defenseless"+pattern S_RESOLUTE = GroupName "resolute"+pattern S_HASTED = GroupName "hasted"+pattern S_SLOWED = GroupName "slowed"+pattern S_FAR_SIGHTED = GroupName "far-sighted"+pattern S_BLIND = GroupName "blind"+pattern S_KEEN_SMELLING = GroupName "keen-smelling"+pattern S_FOUL_SMELLING = GroupName "foul-smelling"+pattern S_ROSE_SMELLING = GroupName "rose-smelling"+pattern S_RANGED_DEFLECTING = GroupName "ranged-deflecting"+pattern S_MELEE_DEFLECTING = GroupName "melee-deflecting"+pattern S_SHINY_EYED = GroupName "shiny-eyed"+pattern S_DEAFENED = GroupName "deafened"+pattern S_DEAF = GroupName "deaf"+pattern S_DRUNK = GroupName "drunk"+pattern S_FRENZIED = GroupName "frenzied"+pattern S_REGENERATING = GroupName "regenerating"+pattern S_POISONED = GroupName "poisoned"+pattern S_SLOW_RESISTANT = GroupName "slow resistant"+pattern S_POISON_RESISTANT = GroupName "poison resistant"+pattern S_IMMOBILE = GroupName "immobile"+pattern S_PACIFIED = GroupName "pacified"+pattern S_IRREPLACEABLE = GroupName "irreplaceable"+pattern S_RETAINING = GroupName "retaining"+pattern S_IMPATIENT = GroupName "impatient"+pattern S_DISPOSSESSED = GroupName "dispossessed"+pattern S_WITHHOLDING = GroupName "withholding"+pattern S_PARSIMONIOUS = GroupName "parsimonious"+pattern S_MORE_MOBILE = GroupName "super-mobile"+pattern S_MORE_COMBATIVE = GroupName "super-combative"+pattern S_MORE_DISPLACING = GroupName "super-displacing"+pattern S_MORE_MODIFYING = GroupName "super-modifying"+pattern S_MORE_PATIENT = GroupName "super-patient"+pattern S_MORE_TIDY = GroupName "super-tidy"+pattern S_MORE_PROJECTING = GroupName "super-projecting"+pattern S_MORE_PRACTICAL = GroupName "super-practical"++-- * Content++temporaries :: [ItemKind]+temporaries =+  [tmpStrengthened, tmpWeakened, tmpProtectedMelee, tmpProtectedRanged, tmpDefenseless, tmpResolute, tmpFast20, tmpSlow10, tmpFarSighted, tmpBlind, tmpKeenSmelling, tmpFoulSmelling, tmpRoseSmelling, tmpRangedDeflecting, tmpMeleeDeflecting, tmpNoctovision, tmpDeafened, tmpDeaf, tmpDrunk, tmpBonusSkAggresion, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant, tmpNoSkMove, tmpNoSkMelee, tmpNoSkDisplace, tmpNoSkAlter, tmpNoSkWait, tmpNoSkMoveItem, tmpNoSkProject, tmpNoSkApply, tmpBonusSkMove, tmpBonusSkMelee, tmpBonusSkDisplace, tmpBonusSkAlter, tmpBonusSkWait, tmpBonusSkMoveItem, tmpBonusSkProject, tmpBonusSkApply]++tmpStrengthened,    tmpWeakened, tmpProtectedMelee, tmpProtectedRanged, tmpDefenseless, tmpResolute, tmpFast20, tmpSlow10, tmpFarSighted, tmpBlind, tmpKeenSmelling, tmpFoulSmelling, tmpRoseSmelling, tmpRangedDeflecting, tmpMeleeDeflecting, tmpNoctovision, tmpDeafened, tmpDeaf, tmpDrunk, tmpBonusSkAggresion, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant, tmpNoSkMove, tmpNoSkMelee, tmpNoSkDisplace, tmpNoSkAlter, tmpNoSkWait, tmpNoSkMoveItem, tmpNoSkProject, tmpNoSkApply, tmpBonusSkMove, tmpBonusSkMelee, tmpBonusSkDisplace, tmpBonusSkAlter, tmpBonusSkWait, tmpBonusSkMoveItem, tmpBonusSkProject, tmpBonusSkApply :: ItemKind++-- The @name@ is be used in item description, so it should be an adjective+-- describing the temporary set of aspects.+-- The messages are needed also under @OnSmash@ to display when item removed+-- via @DropItem@ and not via natural periodic activation.+tmpAspects :: GroupName ItemKind -> [Aspect] -> ItemKind+tmpAspects grp aspects =+  let name = fromGroupName grp  -- @iname@ must match @ifreq@, see @myBadGrps@+  in ItemKind+    { isymbol  = toContentSymbol '+'+    , iname    = name+    , ifreq    = [(grp, 1), (CONDITION, 1)]+    , iflavour = zipPlain [BrWhite]+    , icount   = 1+    , irarity  = [(1, 1)]+    , iverbHit = "affect"+    , iweight  = 0+    , idamage  = 0+    , iaspects = -- timeout is 0; activates and vanishes soon,+                 -- depending on initial timer setting+                 aspects+                 ++ [SetFlag Periodic, SetFlag Fragile, SetFlag Condition]+    , ieffects = [ OnSmash $ verbMsgLess name+                   -- announce partial neutralization, but don't spam+                   -- about normal periodic wear each turn+                 , OnSmash $ verbMsgNoLonger name  -- for forced neutralization+                 , verbMsgNoLonger name ]  -- for periodic wear of last copy+    , idesc    = ""  -- no description needed; powers are enough+    , ikit     = []+    }++tmpEffects :: GroupName ItemKind -> Dice -> [Effect] -> ItemKind+tmpEffects grp icount effects =+  let tmp = tmpAspects grp []+  in tmp { icount+         , ieffects = effects ++ ieffects tmp+         }++tmpStrengthened = tmpAspects S_STRENGTHENED [AddSkill SkHurtMelee 20]+tmpWeakened = tmpAspects S_WEAKENED+                         [AddSkill SkHurtMelee (-30)]  -- don't cancel out ^+tmpProtectedMelee = tmpAspects S_PROTECTED_FROM_MELEE+                               [AddSkill SkArmorMelee 50]+tmpProtectedRanged = tmpAspects S_PROTECTED_FROM_RANGED+                                [AddSkill SkArmorRanged 25]+tmpDefenseless = tmpAspects S_DEFENSELESS [ AddSkill SkArmorMelee (-50)+                                          , AddSkill SkArmorRanged (-25) ]+tmpResolute = tmpAspects S_RESOLUTE [ AddSkill SkMaxCalm 60+                                    , AddSkill SkHearing 10 ]+tmpFast20 = tmpAspects S_HASTED [AddSkill SkSpeed 20]+tmpSlow10 = tmpAspects S_SLOWED [AddSkill SkSpeed (-10)]+tmpFarSighted = tmpAspects S_FAR_SIGHTED [AddSkill SkSight 5]+tmpBlind = tmpAspects S_BLIND [ AddSkill SkSight (-99)+                              , AddSkill SkArmorMelee (-30)+                              , AddSkill SkHearing 10 ]+tmpKeenSmelling = tmpAspects S_KEEN_SMELLING [AddSkill SkSmell 2]+tmpFoulSmelling = tmpAspects S_FOUL_SMELLING [AddSkill SkOdor 2]+tmpRoseSmelling = tmpAspects S_ROSE_SMELLING [AddSkill SkOdor (-4)]+tmpRangedDeflecting =+  tmpAspects S_RANGED_DEFLECTING [AddSkill SkDeflectRanged 1]+tmpMeleeDeflecting =+  tmpAspects S_MELEE_DEFLECTING [AddSkill SkDeflectMelee 1]+tmpNoctovision = tmpAspects S_SHINY_EYED [AddSkill SkNocto 2]+tmpDeafened = tmpAspects S_DEAFENED [AddSkill SkHearing (-6)]+tmpDeaf = tmpAspects S_DEAF [ AddSkill SkHearing (-99)+                            , AddSkill SkArmorMelee (-30) ]+tmpDrunk = tmpAspects S_DRUNK [ AddSkill SkHurtMelee 30  -- fury+                              , AddSkill SkArmorRanged (-30)+                              , AddSkill SkSight (-8) ]++tmpBonusSkAggresion =+  tmpAspects S_FRENZIED [ AddSkill SkAggression 5+                        , AddSkill SkArmorMelee (-30) ]++tmpRegenerating =+  tmpEffects S_REGENERATING (4 + 1 `d` 2) [RefillHP 1]+tmpPoisoned =+  tmpEffects S_POISONED (3 + 1 `d` 2) [RefillHP (-1)]+tmpSlow10Resistant =+  tmpEffects S_SLOW_RESISTANT (8 + 1 `d` 4)+             [DropItem 1 1 COrgan S_SLOWED]+tmpPoisonResistant =+  tmpEffects S_POISON_RESISTANT (8 + 1 `d` 4)+             [DropItem 1 maxBound COrgan S_POISONED]++tmpNoSkMove =+  tmpAspects S_IMMOBILE [AddSkill SkMove (-99)]+tmpNoSkMelee =+  tmpAspects S_PACIFIED [AddSkill SkMelee (-99)]+tmpNoSkDisplace =+  tmpAspects S_IRREPLACEABLE [AddSkill SkDisplace (-99)]+tmpNoSkAlter =+  tmpAspects S_RETAINING [AddSkill SkAlter (-99)]+tmpNoSkWait =+  tmpAspects S_IMPATIENT [AddSkill SkWait (-99)]+tmpNoSkMoveItem =+  tmpAspects S_DISPOSSESSED [AddSkill SkMoveItem (-99)]+tmpNoSkProject =+  tmpAspects S_WITHHOLDING [AddSkill SkProject (-99)]+tmpNoSkApply =+  tmpAspects S_PARSIMONIOUS [AddSkill SkApply (-99)]++tmpBonusSkMove =+  tmpAspects S_MORE_MOBILE [AddSkill SkMove 5]+tmpBonusSkMelee =+  tmpAspects S_MORE_COMBATIVE [AddSkill SkMelee 5]+tmpBonusSkDisplace =+  tmpAspects S_MORE_DISPLACING [AddSkill SkDisplace 5]+tmpBonusSkAlter =+  tmpAspects S_MORE_MODIFYING [AddSkill SkAlter 5]+tmpBonusSkWait =+  tmpAspects S_MORE_PATIENT [AddSkill SkWait 5]+tmpBonusSkMoveItem =+  tmpAspects S_MORE_TIDY [AddSkill SkMoveItem 5]+tmpBonusSkProject =+  tmpAspects S_MORE_PROJECTING [AddSkill SkProject 8]+    -- TODO: 11, but let player control potion throwing by non-pointmen;+    -- beware also of capReinforced and other sources of the skill+tmpBonusSkApply =+  tmpAspects S_MORE_PRACTICAL [AddSkill SkApply 5]
GameDefinition/Content/ModeKind.hs view
@@ -1,299 +1,725 @@--- | The type of kinds of game modes for LambdaHack.-module Content.ModeKind ( cdefs ) where+-- | Definitions of game mode kinds.+module Content.ModeKind+  ( -- * Group name patterns+    groupNamesSingleton, groupNames+  , -- * Content+    content+#ifdef EXPOSE_INTERNAL+  -- * Group name patterns+  , pattern RAID, pattern BRAWL, pattern LONG, pattern CRAWL, pattern FOGGY, pattern SHOOTOUT, pattern PERILOUS, pattern HUNT, pattern NIGHT, pattern FLIGHT, pattern BURNING, pattern ZOO, pattern RANGED, pattern AMBUSH, pattern SAFARI, pattern DIG, pattern SEE, pattern SHORT, pattern CRAWL_EMPTY, pattern CRAWL_SURVIVAL, pattern SAFARI_SURVIVAL, pattern BATTLE, pattern BATTLE_DEFENSE, pattern BATTLE_SURVIVAL, pattern DEFENSE, pattern DEFENSE_EMPTY+#endif+  ) where -import qualified Data.IntMap.Strict as IM+import Prelude () -import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Core.Prelude++import qualified Data.Text as T++import Game.LambdaHack.Content.CaveKind (CaveKind, pattern DEFAULT_RANDOM)+import Game.LambdaHack.Content.FactionKind (Outcome (..)) import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Core.Dice+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal -cdefs :: ContentDef ModeKind-cdefs = ContentDef-  { getSymbol = msymbol-  , getName = mname-  , getFreq = mfreq-  , validate = validateModeKind-  , content =-      [campaign, duel, skirmish, ambush, battle, safari, pvp, coop, defense]+import Content.CaveKind hiding (content, groupNames, groupNamesSingleton)+import Content.FactionKind hiding (content, groupNames, groupNamesSingleton)+import Content.ItemKindActor++-- * Group name patterns++groupNamesSingleton :: [GroupName ModeKind]+groupNamesSingleton =+       [RAID, BRAWL, LONG, CRAWL, FOGGY, SHOOTOUT, PERILOUS, HUNT, NIGHT, FLIGHT, BURNING, ZOO, RANGED, AMBUSH, SAFARI, DIG, SEE, SHORT, CRAWL_EMPTY, CRAWL_SURVIVAL, SAFARI_SURVIVAL, BATTLE, BATTLE_DEFENSE, BATTLE_SURVIVAL, DEFENSE, DEFENSE_EMPTY]++pattern RAID, BRAWL, LONG, CRAWL, FOGGY, SHOOTOUT, PERILOUS, HUNT, NIGHT, FLIGHT, BURNING, ZOO, RANGED, AMBUSH, SAFARI, DIG, SEE, SHORT, CRAWL_EMPTY, CRAWL_SURVIVAL, SAFARI_SURVIVAL, BATTLE, BATTLE_DEFENSE, BATTLE_SURVIVAL, DEFENSE, DEFENSE_EMPTY :: GroupName ModeKind++groupNames :: [GroupName ModeKind]+groupNames = []++pattern RAID = GroupName "raid"+pattern BRAWL = GroupName "brawl"+pattern LONG = GroupName "long crawl"+pattern CRAWL = GroupName "crawl"+pattern FOGGY = GroupName "foggy shootout"+pattern SHOOTOUT = GroupName "shootout"+pattern PERILOUS = GroupName "perilous hunt"+pattern HUNT = GroupName "hunt"+pattern NIGHT = GroupName "night flight"+pattern FLIGHT = GroupName "flight"+pattern BURNING = GroupName "burning zoo"+pattern ZOO = GroupName "zoo"+pattern RANGED = GroupName "ranged ambush"+pattern AMBUSH = GroupName "ambush"+pattern SAFARI = GroupName "safari"+pattern DIG = GroupName "dig"+pattern SEE = GroupName "see"+pattern SHORT = GroupName "short"+pattern CRAWL_EMPTY = GroupName "crawlEmpty"  -- only the first word matters+pattern CRAWL_SURVIVAL = GroupName "crawlSurvival"+pattern SAFARI_SURVIVAL = GroupName "safariSurvival"+pattern BATTLE = GroupName "battle"+pattern BATTLE_DEFENSE = GroupName "battleDefense"+pattern BATTLE_SURVIVAL = GroupName "battleSurvival"+pattern DEFENSE = GroupName "defense"+pattern DEFENSE_EMPTY = GroupName "defenseEmpty"++-- * Content++content :: [ModeKind]+content =+  [raid, brawl, crawl, shootout, hunt, flight, zoo, ambush, safari, dig, see, short, crawlEmpty, crawlSurvival, safariSurvival, battle, battleDefense, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverCrawl, screensaverShootout, screensaverHunt, screensaverFlight, screensaverZoo, screensaverAmbush, screensaverSafari]++raid,    brawl, crawl, shootout, hunt, flight, zoo, ambush, safari, dig, see, short, crawlEmpty, crawlSurvival, safariSurvival, battle, battleDefense, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverCrawl, screensaverShootout, screensaverHunt, screensaverFlight, screensaverZoo, screensaverAmbush, screensaverSafari :: ModeKind++-- What other symmetric (two only-one-moves factions) and asymmetric vs crowd+-- scenarios make sense (e.g., are good for a tutorial or for standalone+-- extreme fun or are impossible as part of a crawl)?+-- sparse melee at night: no, shade ambush in brawl is enough+-- dense melee: no, keeping big party together is a chore and big enemy+--   party is less fun than huge enemy party+-- crowd melee in daylight: no, possible in crawl and at night is more fun+-- sparse ranged at night: no, less fun than dense and if no reaction fire,+--   just a camp fest or firing blindly+-- dense ranged in daylight: no, less fun than at night with flares+-- crowd ranged: no, fish in a barrel, less predictable and more fun inside+--   crawl, even without reaction fire++raid = ModeKind+  { mname   = "raid (tutorial, 1)"+  , mfreq   = [(RAID, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = True+  , mattract = False+  , mroster = rosterRaid+  , mcaves  = cavesRaid+  , mendMsg = [ (Killed, "This expedition has gone wrong. However, scientific mind does not despair, but analyzes and corrects. Did you perchance awake one animal too many? Did you remember to try using all consumables at your disposal for your immediate survival? Did you choose a challenge with difficulty level within your means? Answer honestly, ponder wisely, experiment methodically.")+              , (Defeated, "Regrettably, the other team snatched the grant, while you were busy contemplating natural phenomena. Science is a competitive sport, as sad as it sounds. It's not enough to make a discovery, you have to get there first.")+              , (Escape, "You've got hold of the machine! Think of the hours of fun taking it apart and putting it back together again! That's a great first step on your quest to solve the typing problems of the world.") ]+  , mrules  = T.intercalate "\n"+      [ "* One level only"+      , "* Two heroes vs. Spawned enemies"+      , "* Gather gold"+      , "* Find a way out and escape ASAP"+      ]+  , mdesc   = "An incredibly advanced typing machine worth 100 gold is buried at the exit of this maze. Be the first to find it and fund a research team that makes typing accurate and dependable forever."+  , mreason = "In addition to initiating the (loose) game plot, this adventure provides an introductory tutorial. Relax, explore, gather loot, find the way out and escape. With some luck, you won't even need to fight anything."+  , mhint   = "You can't use gathered items in your next encounters, so trigger any consumables at will. Feel free to scout with only one of the heroes and keep the other one immobile, e.g., standing guard over the squad's shared inventory stash. If in grave danger, retreat with the scout to join forces with the guard. The more gold collected and the faster the victory, the higher your score in this encounter."   }-campaign,        duel, skirmish, ambush, battle, safari, pvp, coop, defense :: ModeKind -campaign = ModeKind-  { msymbol  = 'a'-  , mname    = "campaign"-  , mfreq    = [("campaign", 1)]-  , mplayers = playersCampaign-  , mcaves   = cavesCampaign-  , mdesc    = "Don't let wanton curiosity, greed and the creeping abstraction madness keep you down there in the darkness for too long!"+brawl = ModeKind  -- sparse melee in daylight, with shade for melee ambush+  { mname   = "brawl (tutorial, 2)"+  , mfreq   = [(BRAWL, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = True+  , mattract = False+  , mroster = rosterBrawl+  , mcaves  = cavesBrawl+  , mendMsg = [ (Killed, "The inquisitive scholars turned out to be envious of our deep insight to the point of outright violence. It would still not result in such a defeat and recanting of our thesis if we figured out to use terrain to protect us from missiles or even completely hide our presence. It would also help if we honourably kept our ground together to the end, at the same time preventing the overwhelming enemy forces from brutishly ganging up on our modest-sized, though valiant, research team.")+              , (Conquer, "That's settled: local compactness *is* necessary for relative completeness, given the assumptions.") ]+  , mrules  = T.intercalate "\n"+      [ "* One level only"+      , "* Three heroes vs. Three human enemies"+      , "* Minimize losses"+      , "* Incapacitate all enemies ASAP"+      ]+  , mdesc   = "Your research team disagrees over a drink with some gentlemen scientists about premises of a relative completeness theorem and there's only one way to settle that."+      -- Not enough space with square fonts and also this is more of a hint than a flavour: Remember to keep your party together when opponents are spotted, or they might be tempted to silence solitary disputants one by one and so win the altercation.+  , mreason = "In addition to advancing game plot, this encounter trains melee, squad formation and stealth. The battle is symmetric in goals (incapacitate all enemies) and in squad capabilities (only the pointman moves, others either melee or wait)."+  , mhint   =  T.intercalate "\n"+    [ "Run a short distance with Shift or LMB, switch the pointman with Tab, repeat. In open terrain, if you keep distance between teammates, this resembles the leap frog infantry tactics. For best effects, end each sprint behind a cover or concealment."+    , "Observe and mimic the enemies. If you can't see an enemy that apparently can see you, in reversed circumstances you would have the same advantage. Savour the relative fairness --- you won't find any in the main crawl adventure that follows."+    , "If you get beaten repeatedly, try using all consumables you find. Ponder the hints from the defeat message, in particular the one about keeping your party together once the opponents are spotted. However, if you want to discover a winning tactics on your own, make sure to ignore any such tips until you succeed."+    ]   } -duel = ModeKind-  { msymbol  = 'u'-  , mname    = "duel"-  , mfreq    = [("duel", 1)]-  , mplayers = playersDuel-  , mcaves   = cavesSkirmish-  , mdesc    = "You disagreed about the premises of a relative completeness theorem and there's only one way to settle that."+crawl = ModeKind+  { mname   = "long crawl (main)"+  , mfreq   = [(LONG, 1), (CRAWL, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterCrawl+  , mcaves  = cavesCrawl+  , mendMsg = [ (Killed, killedMsg)+              , (Escape, "It's better to live to tell the tale than to choke on more than one can swallow. There was no more exquisite cultural artifacts and glorious scientific wonders in these forbidding tunnels anyway. Or were there?") ]+  , mrules  = T.intercalate "\n"+      [ "* Many levels"+      , "* Three heroes vs. Spawned enemies"+      , "* Gather gold, gems and elixirs"+      , "* Find a way out and escape ASAP"+      ]+  , mdesc   = "Enjoy the peaceful seclusion of these cold austere tunnels, but don't let wanton curiosity, greed and the ever-creeping abstraction madness keep you down there for too long. If you find survivors (whole or perturbed or segmented) of the past scientific missions, exercise extreme caution and engage or ignore at your discretion."+  , mreason = "This is the main, longest and most replayable scenario of the game. It's crucial that you gather the most interesting cultural artifacts such as gold, gems and elixirs. Equally importantly, you have to limit the permanent sanity deterioration of your scientific expedition members by minimizing the time they are exposed to the horrors of the underworld."+  , mhint   = "If you keep dying, attempt the subsequent adventures as a breather (perhaps at lowered difficulty). They fill the gaps in the plot and teach particular skills that may come in handy and help you discover new tactics of your own or come up with a strategy for staving off the attrition. Also experimenting with the initial adventures may answer some questions you didn't have when you attempted them originally."   }+ where+   killedMsg = T.intercalate "\n"+     [ "To think that followers of science and agents of enlightenment would earn death as their reward! Where did we err in our ways? Perhaps nature should not have been disturbed so brashly and the fell beasts woken up from their slumber so eagerly?"+     , "Perhaps the gathered items should have been used for scientific experiments on the spot rather than hoarded as if of base covetousness? Or perhaps the challenge, chosen freely but without the foreknowledge of the grisly difficulty, was insurmountable and forlorn from the start, despite the enormous power of educated reason at out disposal?"+     ] -skirmish = ModeKind-  { msymbol  = 'k'-  , mname    = "skirmish"-  , mfreq    = [("skirmish", 1)]-  , mplayers = playersSkirmish-  , mcaves   = cavesSkirmish-  , mdesc    = "The scoring system of a programming contest fails to determine the winning team and participants take matters into their own hands."+-- The trajectory tip is important because of tactics of scout looking from+-- behind a bush and others hiding in mist. If no suitable bushes,+-- fire once and flee into mist or behind cover. Then whomever is out of LOS+-- range or inside mist can shoot at the last seen enemy locations,+-- adjusting aim according to sounds and incoming missile trajectories.+-- If the scout can't find bushes or glass building to set a lookout,+-- the other team members are more spotters and guardians than snipers+-- and that's their only role, so a small party makes sense.+shootout = ModeKind  -- sparse ranged in daylight+  { mname   = "foggy shootout (3)"+  , mfreq   = [(FOGGY, 1), (SHOOTOUT, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterShootout+  , mcaves  = cavesShootout+  , mendMsg = [ (Killed, killedMsg)+              , (Conquer, "That was a good fight, with scientifically accurate application of missiles, cover and concealment. Not even skilled logicians can routinely deduce enemy position from the physical trajectory of their projectiles nor by firing without line of sight and interpreting auditory cues. However, while this steep hurdle is overcome, the dispute is not over yet.") ]+  , mrules  = T.intercalate "\n"+      [ "* One level only"+      , "* Three heroes vs. Three human enemies"+      , "* Minimize losses"+      , "* Incapacitate all enemies ASAP"+      ]+  , mdesc   = "Whose arguments are most striking and whose ideas fly fastest? Let's scatter up, attack the problems from different angles and find out."+  , mreason = "This adventure teaches the ranged combat skill in the simplified setup of fully symmetric battle."+  , mhint   = "Try to come up with the best squad formation for this tactical challenge. Don't despair if you run out of ammo, because if you aim truly, enemy has few hit points left at this point. In turn, when trying to avoid enemy projectiles, you can display the trajectory of any soaring entity by pointing it with the crosshair in aiming mode."   }+ where+   killedMsg = T.intercalate "\n"+     [ "This is a disgrace. What have we missed in our theoretic models of this fight? Did we miss a human lookout placed in a covered but unobstructed spot that lets the rest of the squad snipe from concealment or from a safe distance?"+     , "Barring that, would we end up in a better shape even if we all hid and only fired blindly? We'd listen to impact sounds and wait vigilantly for incoming enemy missiles in order to register their trajectories and derive hints of enemy location. Apparently, ranged combat requires a change of pace and better planning than our previous simple but efficient calculations accustomed us to."+     ] -ambush = ModeKind-  { msymbol  = 'm'-  , mname    = "ambush"-  , mfreq    = [("ambush", 1)]-  , mplayers = playersAmbush-  , mcaves   = cavesAmbush-  , mdesc    = "Surprising, striking ideas and fast execution are what makes or breaks a creative team!"+hunt = ModeKind  -- melee vs ranged with reaction fire in daylight+  { mname   = "perilous hunt (4)"+  , mfreq   = [(PERILOUS, 1), (HUNT, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterHunt+  , mcaves  = cavesHunt+  , mendMsg = [ (Killed, "Leaving concealment might have not been rational enough, leaving cover is hard to justify on a scientific basis and wandering off on an area of a heated dispute is foolhardy. All this is doubly regrettable, given that our cold-hearted opponents supported their weak arguments with inexplicably effective telegraphy and triangulation equipment. And we so deserve a complete intellectual victory, if only we strove to lower the difficulty of this altercation instead of raising it.")+      -- this is in the middle of the scenario list and the mission is not tricky, so a subtle reminder about lowering difficulty, in case the player struggles+              , (Conquer, "We chased them off and proved our argument, like we knew that we would. It feels efficient to stick together and prevail. We taught them a lesson in rationality, despite their superior scientific equipment. Scientific truth prevails over brute force.") ]+  , mrules  = T.intercalate "\n"+      [ "* One level only"+      , "* Seven heroes vs. Seven human enemies capable of concurrent attacks"+      , "* Minimize losses"+      , "* Incapacitate all human enemies ASAP"+      ]+  , mdesc   = "Who is the hunter and who is the prey? The only criterion is last man standing when the chase for truth ends."+  , mreason = "This adventure is quite a tactical challenge, because enemies are allowed to fling their ammo simultaneously at your team, which has no such ability."+  , mhint   = "Try not to outshoot the enemy, but to instead focus more on melee tactics. A useful concept here is communication overhead. Any team member that is not waiting and spotting for everybody, but acts, e.g., melees or moves or manages items, slows down all other team members by roughly 10%, because they need to keep track of his actions. Therefore, if other heroes melee, consider carefully if it makes sense to come to their aid, slowing them while you move, or if it's better to stay put and monitor the perimeter. This is true for all factions and all actors on each level separately, except the pointman of each faction, if it has one."  -- this also eliminates lag in big battles and helps the player to focus on combat and not get distracted by distant team members frantically trying to reach the battleground in time   } -battle = ModeKind-  { msymbol  = 'b'-  , mname    = "battle"-  , mfreq    = [("battle", 1)]-  , mplayers = playersBattle-  , mcaves   = cavesBattle-  , mdesc    = "Odds are stacked against those that unleash the horrors of abstraction."+flight = ModeKind  -- asymmetric ranged and stealth race at night+  { mname   = "night flight (5)"+  , mfreq   = [(NIGHT, 1), (FLIGHT, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterFlight+  , mcaves  = cavesFlight+  , mendMsg = [ (Killed, killedMsg)+              , (Conquer, "It was enough to reach the escape area marked by yellow '>' symbol. Spilling that much blood was risky. unnecessary and alerted the authorities. Having said that --- impressive indeed.") ]+  , mrules  = T.intercalate "\n"+      [ "* One level only"+      , "* Three heroes vs. Seven human enemies capable of concurrent attacks"+      , "* Minimize losses"+      , "* Gather gems"+      , "* Find a way out and escape ASAP"+      ]+  , mdesc   = "Dwelling into dark matters is dangerous, so avoid the crowd of firebrand disputants, catch any gems of thought, find a way out and bring back a larger team to shed new light on the field."+  , mreason = "The focus of this installment is on stealthy exploration under the threat of numerically superior enemy."+  , mhint   = ""   }+ where+   killedMsg = T.intercalate "\n"+     [ "Somebody must have tipped the enemies of free inquiry off. However, us walking along a lit trail, yelling, could have been a contributing factor. Also, it's worth noting that the torches prepared for this assault are best used as thrown makeshift flares."+     , "On the other hand, equipping a lit torch makes one visible in the dark, regrettably but not quite unexpectedly to a scientific mind. Lastly, the goal of this foray was to definitely disengage from the fruitless dispute, via a way out marked by a yellow '>' sign, and to gather treasure that would support our future research. Not to harass every nearby scientific truth denier, as much as they do deserve it."+     ] -safari = ModeKind-  { msymbol  = 'f'-  , mname    = "safari"-  , mfreq    = [("safari", 1)]-  , mplayers = playersSafari-  , mcaves   = cavesSafari-  , mdesc    = "In this simulation you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent (exit at the bottommost level)."+zoo = ModeKind  -- asymmetric crowd melee at night+  { mname   = "burning zoo (6)"+  , mfreq   = [(BURNING, 1), (ZOO, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterZoo+  , mcaves  = cavesZoo+  , mendMsg = [ (Killed, "Against such an onslaught, only clever positioning, use of terrain and patient vigilance gives any chance of survival.")+              , (Conquer, "That was a grim harvest. Science demands sacrifices.") ]+  , mrules  = T.intercalate "\n"+      [ "* One level only"+      , "* Five heroes vs. Many enemies"+      , "* Minimize losses"+      , "* Incapacitate all enemies ASAP"+      ]+  , mdesc   = "The heat of the dispute reaches the nearby Wonders of Science and Nature exhibition, igniting greenery, nets and cages. Crazed animals must be dissuaded from ruining precious scientific equipment and setting back the otherwise fruitful exchange of ideas."+  , mreason = "This is a crowd control exercise, at night, with a raging fire."+  , mhint   = "Note that communication overhead, as explained in perilous hunt adventure hints, makes it impossible for any faction to hit your heroes by more than 10 normal speed actors each turn. However, this is still too much, so position is everything."   } -pvp = ModeKind-  { msymbol  = 'v'-  , mname    = "PvP"-  , mfreq    = [("PvP", 1)]-  , mplayers = playersPvP-  , mcaves   = cavesSkirmish-  , mdesc    = "(Not usable right now.) This is a fight to the death between two human-controlled teams."+-- The tactic is to sneak in the dark, highlight enemy with thrown torches+-- (and douse thrown enemy torches with blankets) and only if this fails,+-- actually scout using extended noctovision.+-- With reaction fire, larger team is more fun.+--+-- For now, while we have no shooters with timeout, massive ranged battles+-- without reaction fire don't make sense, because then usually only one hero+-- shoots (and often also scouts) and others just gather ammo.+ambush = ModeKind  -- dense ranged with reaction fire vs melee at night+  { mname   = "ranged ambush (7)"+  , mfreq   = [(RANGED, 1), (AMBUSH, 1), (CAMPAIGN_SCENARIO, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterAmbush+  , mcaves  = cavesAmbush+  , mendMsg = [ (Killed, killedMsg)+              , (Conquer, "The new instant telegraphy equipment enabling simultaneous ranged attacks with indirect triangulation and aiming proved effective beyond expectation. Your ideas are safe, your research programme on track, your chartered company ready to launch and introduce progress and science into every household of the nation.") ]+  , mrules  = T.intercalate "\n"+      [ "* One level only"+      , "* Three heroes with concurrent attacks vs. Unidentified foes"+      , "* Minimize losses"+      , "* Assert control of the situation ASAP"+      ]+  , mdesc   = "Prevent hijacking of your ideas at all cost! Be stealthy, be observant, be aggressive. Fast execution is what makes or breaks a creative team."+  , mreason = "In this adventure, finally, your heroes are able to all use ranged attacks at once, given enough ammunition."+  , mhint   = "Beware of friendly fire, particularly from explosives. But you need no more hints. Go fulfill your destiny! For Science!"   }+ where+   killedMsg = T.intercalate "\n"+     [ "You turned out to be the prey, this time, not the hunter. In fact, you are not even in the hunters' league. When fighting against such odds, passively waiting for enemy to spring a trap is to no avail, because a professional team can sneak in darkness and ambush the ambushers."+     , "Granted, good positioning is crucial, so that each squad member can overwatch the battlefield and fire opportunistically, using the recently recovered instant telegraphy equipment. However, there is no hope without active scouting, throwing lit objects and probing suspect areas with missiles while paying attention to sounds. And that may still not be enough."+     ] -coop = ModeKind-  { msymbol  = 'o'-  , mname    = "Coop"-  , mfreq    = [("Coop", 1)]-  , mplayers = playersCoop-  , mcaves   = cavesCampaign-  , mdesc    = "(This mode is intended solely for automated testing.)"+safari = ModeKind  -- Easter egg available only via screensaver+  { mname   = "safari"+  , mfreq   = [(SAFARI, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterSafari+  , mcaves  = cavesSafari+  , mendMsg = []+  , mrules  = T.intercalate "\n"+      [ "* Three levels"+      , "* Many teammates capable of concurrent action vs. Many enemies"+      , "* Minimize losses"+      , "* Find a way out and escape ASAP"+      ]+  , mdesc   = "\"In this enactment you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent. Exit at the bottommost level.\" This is a drama script recovered from a monster nest debris."+  , mreason = "This is an Easter egg. The default squad doctrine is that all team members follow the pointman, but it can be changed from the settings submenu of the main menu."+  , mhint   = ""   } -defense = ModeKind-  { msymbol  = 'e'-  , mname    = "defense"-  , mfreq    = [("defense", 1)]-  , mplayers = playersDefense-  , mcaves   = cavesCampaign-  , mdesc    = "Don't let the humans defile your abstract secrets and flee, like the vulgar, literal, base scoundrels that they are!"+-- * Testing modes++dig = ModeKind+  { mname   = "dig"+  , mfreq   = [(DIG, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterCrawlEmpty+  , mcaves  = cavesDig+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Delve deeper!"+  , mreason = ""+  , mhint   = ""   } +see = ModeKind+  { mname   = "see"+  , mfreq   = [(SEE, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterCrawlEmpty+  , mcaves  = cavesSee+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "See all!"+  , mreason = ""+  , mhint   = ""+  } -playersCampaign, playersDuel, playersSkirmish, playersAmbush, playersBattle, playersSafari, playersPvP, playersCoop, playersDefense :: Players+short = ModeKind+  { mname   = "short"+  , mfreq   = [(SHORT, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterCrawlEmpty+  , mcaves  = cavesShort+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "See all short scenarios!"+  , mreason = ""+  , mhint   = ""+  } -playersCampaign = Players-  { playersList = [ playerHero-                  , playerMonster-                  , playerAnimal ]-  , playersEnemy = [ ("Adventurer Party", "Monster Hive")-                   , ("Adventurer Party", "Animal Kingdom") ]-  , playersAlly = [("Monster Hive", "Animal Kingdom")] }+crawlEmpty = ModeKind+  { mname   = "crawl empty"+  , mfreq   = [(CRAWL_EMPTY, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterCrawlEmpty+  , mcaves  = cavesCrawlEmpty+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Enjoy the extra legroom."+  , mreason = ""+  , mhint   = ""+  } -playersDuel = Players-  { playersList = [ playerHero { playerName = "White Recursive"-                               , playerInitial = 1 }-                  , playerAntiHero { playerName = "Red Iterative"-                                   , playerInitial = 1 }-                  , playerHorror ]-  , playersEnemy = [ ("White Recursive", "Red Iterative")-                   , ("White Recursive", "Horror Den")-                   , ("Red Iterative", "Horror Den") ]-  , playersAlly = [] }+crawlSurvival = ModeKind+  { mname   = "crawl survival"+  , mfreq   = [(CRAWL_SURVIVAL, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterCrawlSurvival+  , mcaves  = cavesCrawl+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Lure the human intruders deeper and deeper."+  , mreason = ""+  , mhint   = ""+  } -playersSkirmish = playersDuel-  { playersList = [ playerHero {playerName = "White Haskell"}-                  , playerAntiHero {playerName = "Purple Agda"}-                  , playerHorror ]-  , playersEnemy = [ ("White Haskell", "Purple Agda")-                   , ("White Haskell", "Horror Den")-                   , ("Purple Agda", "Horror Den") ] }+safariSurvival = ModeKind+  { mname   = "safari survival"+  , mfreq   = [(SAFARI_SURVIVAL, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterSafariSurvival+  , mcaves  = cavesSafari+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "In this enactment you'll discover the joys of being hunted among the most exquisite of Earth's flora and fauna, both animal and semi-intelligent."+  , mreason = ""+  , mhint   = ""+  } -playersAmbush = playersDuel-  { playersList = [ playerHero {playerName = "Yellow Idris"}-                  , playerAntiHero {playerName = "Blue Epigram"}-                  , playerHorror ]-  , playersEnemy = [ ("Yellow Idris", "Blue Epigram")-                   , ("Yellow Idris", "Horror Den")-                   , ("Blue Epigram", "Horror Den") ] }+battle = ModeKind+  { mname   = "battle"+  , mfreq   = [(BATTLE, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterBattle+  , mcaves  = cavesBattle+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Odds are stacked against those that unleash the horrors of abstraction."+  , mreason = ""+  , mhint   = ""+  } -playersBattle = Players-  { playersList = [ playerHero {playerInitial = 5}-                  , playerMonster { playerInitial = 15-                                  , playerIsSpawn = False }-                  , playerAnimal { playerInitial = 10-                                 , playerIsSpawn = False } ]-  , playersEnemy = [ ("Adventurer Party", "Monster Hive")-                   , ("Adventurer Party", "Animal Kingdom") ]-  , playersAlly = [("Monster Hive", "Animal Kingdom")] }+battleDefense = ModeKind+  { mname   = "battle defense"+  , mfreq   = [(BATTLE_DEFENSE, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterBattleDefense+  , mcaves  = cavesBattle+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Odds are stacked for those that breathe mathematics."+  , mreason = ""+  , mhint   = ""+  } -playersSafari = Players-  { playersList = [ playerMonster { playerName = "Monster Tourist Office"-                                  , playerIsSpawn = False-                                  , playerEntry = -4-                                  , playerInitial = 10-                                  , playerAI = False-                                  , playerUI = True }-                  , playerCivilian { playerName = "Hunam Convict Pack"-                                   , playerEntry = -4 }-                  , playerAnimal { playerName =-                                     "Animal Magnificent Specimen Variety"-                                 , playerIsSpawn = False-                                 , playerEntry = -7-                                 , playerInitial = 7 }-                  , playerAnimal { playerName =-                                     "Animal Exquisite Herds and Packs"-                                 , playerIsSpawn = False-                                 , playerEntry = -10-                                 , playerInitial = 20 } ]-  , playersEnemy = [ ("Monster Tourist Office", "Hunam Convict Pack")-                   , ("Monster Tourist Office",-                      "Animal Magnificent Specimen Variety")-                   , ("Monster Tourist Office",-                      "Animal Exquisite Herds and Packs") ]-  , playersAlly = [( "Animal Magnificent Specimen Variety"-                   , "Animal Exquisite Herds and Packs" )] }+battleSurvival = ModeKind+  { mname   = "battle survival"+  , mfreq   = [(BATTLE_SURVIVAL, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterBattleSurvival+  , mcaves  = cavesBattle+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Odds are stacked for those that ally with the strongest."+  , mreason = ""+  , mhint   = ""+  } -playersPvP = Players-  { playersList = [ playerHero {playerName = "Red"}-                  , playerHero {playerName = "Blue"}-                  , playerHorror ]-  , playersEnemy = [ ("Red", "Blue")-                   , ("Red", "Horror Den")-                   , ("Blue", "Horror Den") ]-  , playersAlly = [] }+defense = ModeKind  -- perhaps a real scenario in the future+  { mname   = "defense"+  , mfreq   = [(DEFENSE, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterDefense+  , mcaves  = cavesCrawl+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Don't let human interlopers defile your abstract secrets and flee unpunished!"+  , mreason = "This is an initial sketch of the reversed crawl game mode. Play on high difficulty to avoid guaranteed victories against the pitiful humans."+  , mhint   = ""+  } -playersCoop = Players-  { playersList = [ playerAntiHero { playerName = "Coral" }-                  , playerAntiHero { playerName = "Amber"-                                   , playerLeader = False }-                  , playerAntiHero { playerName = "Green" }-                  , playerAnimal { playerUI = True }-                  , playerMonster-                  , playerMonster { playerName = "Leaderless Monster Hive"-                                  , playerLeader = False } ]-  , playersEnemy = [ ("Coral", "Monster Hive")-                   , ("Amber", "Monster Hive")-                   , ("Animal Kingdom", "Leaderless Monster Hive") ]-  , playersAlly = [ ("Coral", "Amber")-                  , ("Coral", "Green")-                  , ("Amber", "Green")-                  , ("Green", "Animal Kingdom")-                  , ("Green", "Monster Hive")-                  , ("Green", "Leaderless Monster Hive") ] }+defenseEmpty = ModeKind+  { mname   = "defense empty"+  , mfreq   = [(DEFENSE_EMPTY, 1)]+  , mtutorial = False+  , mattract = False+  , mroster = rosterDefenseEmpty+  , mcaves  = cavesCrawlEmpty+  , mendMsg = []+  , mrules  = ""+  , mdesc   = "Lord over empty halls."+  , mreason = ""+  , mhint   = ""+  } -playersDefense = Players-  { playersList = [ playerMonster { playerInitial = 1-                                  , playerAI = False-                                  , playerUI = True }-                  , playerAntiHero { playerName = "Yellow"-                                   , playerInitial = 10 }-                  , playerAnimal ]-  , playersEnemy = [ ("Yellow", "Monster Hive")-                   , ("Yellow", "Animal Kingdom") ]-  , playersAlly = [("Monster Hive", "Animal Kingdom")] }+-- * Screensaver modes -playerHero, playerAntiHero, playerCivilian, playerMonster, playerAnimal, playerHorror :: Player+screensaverRaid = raid+  { mname   = "auto-raid (1)"+  , mfreq   = [(INSERT_COIN, 2)]+  , mattract = True+  } -playerHero = Player-  { playerName = "Adventurer Party"-  , playerFaction = "hero"-  , playerIsSpawn = False-  , playerIsHero = True-  , playerEntry = -1-  , playerInitial = 3-  , playerLeader = True-  , playerAI = False-  , playerUI = True+screensaverBrawl = brawl+  { mname   = "auto-brawl (2)"+  , mfreq   = []+  , mattract = True   } -playerAntiHero = playerHero-  { playerAI = True-  , playerUI = False+screensaverCrawl = crawl+  { mname   = "auto-crawl (long)"+  , mfreq   = []+  , mattract = True   } -playerCivilian = Player-  { playerName = "Civilian Crowd"-  , playerFaction = "civilian"-  , playerIsSpawn = False-  , playerIsHero = False-  , playerEntry = -1-  , playerInitial = 3-  , playerLeader = False  -- unorganized-  , playerAI = True-  , playerUI = False+screensaverShootout = shootout+  { mname   = "auto-shootout (3)"+  , mfreq   = [(INSERT_COIN, 2)]+  , mattract = True   } -playerMonster = Player-  { playerName = "Monster Hive"-  , playerFaction = "monster"-  , playerIsSpawn = True-  , playerIsHero = False-  , playerEntry = -3-  , playerInitial = 5-  , playerLeader = True-  , playerAI = True-  , playerUI = False+screensaverHunt = hunt+  { mname   = "auto-hunt (4)"+  , mfreq   = [(INSERT_COIN, 2)]+  , mattract = True   } -playerAnimal = Player-  { playerName = "Animal Kingdom"-  , playerFaction = "animal"-  , playerIsSpawn = True-  , playerIsHero = False-  , playerEntry = -2-  , playerInitial = 3-  , playerLeader = False-  , playerAI = True-  , playerUI = False+screensaverFlight = flight+  { mname   = "auto-flight (5)"+  , mfreq   = [(INSERT_COIN, 2)]+  , mattract = True   } -playerHorror = Player-  { playerName = "Horror Den"-  , playerFaction = "horror"-  , playerIsSpawn = False-  , playerIsHero = False-  , playerEntry = -1-  , playerInitial = 0-  , playerLeader = False-  , playerAI = True-  , playerUI = False+screensaverZoo = zoo+  { mname   = "auto-zoo (6)"+  , mfreq   = []+  , mattract = True   } +screensaverAmbush = ambush+  { mname   = "auto-ambush (7)"+  , mfreq   = []+  , mattract = True+  } -cavesCampaign, cavesSkirmish, cavesAmbush, cavesBattle, cavesSafari :: Caves+screensaverSafari = safari+  { mname   = "auto-safari"+  , mfreq   = [(INSERT_COIN, 1)]+  , mattract = True+  } -cavesCampaign = IM.fromList $ [ (-1, ("caveRogue", Just True))-                              , (-2, ("caveRogue", Nothing))-                              , (-3, ("caveEmpty", Nothing)) ]-                              ++ zip [-4, -5..(-9)] (repeat ("dng", Nothing))-                              ++ [(-10, ("caveNoise", Nothing))]+rosterRaid, rosterBrawl, rosterCrawl, rosterShootout, rosterHunt, rosterFlight, rosterZoo, rosterAmbush, rosterSafari, rosterCrawlEmpty, rosterCrawlSurvival, rosterSafariSurvival, rosterBattle, rosterBattleDefense, rosterBattleSurvival, rosterDefense, rosterDefenseEmpty :: Roster -cavesSkirmish = IM.fromList [(-3, ("caveSkirmish", Nothing))]+rosterRaid =+  [ ( ANIMAL_REPRESENTATIVE  -- starting over escape+    , [(-2, 2, ANIMAL)] )+  , ( EXPLORER_SHORT+    , [(-2, 2, HERO)] )+  , ( COMPETITOR_SHORT+    , [(-2, 1, HERO)] )+  , (HORROR_REPRESENTATIVE, []) ]  -- for summoned monsters -cavesAmbush = IM.fromList [(-5, ("caveAmbush", Nothing))]+rosterBrawl =+  [ ( EXPLORER_NO_ESCAPE+    , [(-2, 3, BRAWLER_HERO)] )+  , ( COMPETITOR_NO_ESCAPE+    , [(-2, 3, BRAWLER_HERO)] )+  , (HORROR_REPRESENTATIVE, []) ] -cavesBattle = IM.fromList [(-3, ("caveBattle", Nothing))]+rosterCrawl =+  [ ( ANIMAL_REPRESENTATIVE  -- starting over escape+    , -- Fun from the start to avoid empty initial level:+      [ (-1, 1 + 1 `d` 2, ANIMAL)+      -- Huge battle at the end:+      , (-10, 100, MOBILE_ANIMAL) ] )+  , ( EXPLORER_REPRESENTATIVE+        -- start on stairs so that stash is handy+    , [(-1, 3, HERO)] )+  , ( MONSTER_REPRESENTATIVE+    , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] ) ] -cavesSafari = IM.fromList [ (-4, ("caveSafari1", Nothing))-                          , (-7, ("caveSafari2", Nothing))-                          , (-10, ("caveSafari3", Just False)) ]+-- Exactly one scout gets a sight boost, to help the aggressor, because he uses+-- the scout for initial attack, while camper (on big enough maps)+-- can't guess where the attack would come and so can't position his single+-- scout to counter the stealthy advance.+rosterShootout =+  [ ( EXPLORER_NO_ESCAPE+    , [(-5, 2, RANGER_HERO), (-5, 1, SCOUT_HERO)] )+  , ( COMPETITOR_NO_ESCAPE+    , [(-5, 2, RANGER_HERO), (-5, 1, SCOUT_HERO)] )+  , (HORROR_REPRESENTATIVE, []) ]++rosterHunt =+  [ ( EXPLORER_NO_ESCAPE+    , [(-6, 7, SOLDIER_HERO)] )+  , ( COMPETITOR_NO_ESCAPE+    , [(-6, 6, AMBUSHER_HERO), (-6, 1, SCOUT_HERO)] )+  , (HORROR_REPRESENTATIVE, []) ]++rosterFlight =+  [ ( COMPETITOR_NO_ESCAPE  -- start on escape+    , [(-7, 6, AMBUSHER_HERO), (-7, 1, SCOUT_HERO)] )+  , ( EXPLORER_MEDIUM+    , [(-7, 2, ESCAPIST_HERO), (-7, 1, SCOUT_HERO)] )+      -- second on the list to let foes occupy the escape+  , (HORROR_REPRESENTATIVE, []) ]++rosterZoo =+  [ ( EXPLORER_TRAPPED+    , [(-8, 5, SOLDIER_HERO)] )+  , ( ANIMAL_CAPTIVE+    , [(-8, 100, MOBILE_ANIMAL)] )+  , (HORROR_REPRESENTATIVE, []) ]  -- for summoned monsters++rosterAmbush =+  [ ( EXPLORER_NO_ESCAPE+    , [(-9, 5, AMBUSHER_HERO), (-9, 1, SCOUT_HERO)] )+  , ( COMPETITOR_NO_ESCAPE+    , [(-9, 12, SOLDIER_HERO)] )+  , (HORROR_REPRESENTATIVE, []) ]++-- No horrors faction needed, because spawned heroes land in civilian faction.+rosterSafari =+  [ ( MONSTER_TOURIST+    , [(-4, 15, MONSTER)] )+  , ( CONVICT_REPRESENTATIVE+    , [(-4, 2, CIVILIAN)] )+  , ( ANIMAL_MAGNIFICENT+    , [(-7, 15, MOBILE_ANIMAL)] )+  , ( ANIMAL_EXQUISITE  -- start on escape+    , [(-10, 20, MOBILE_ANIMAL)] ) ]++rosterCrawlEmpty =+  [ ( EXPLORER_PACIFIST+    , [(-1, 1, HERO)] )+  , (HORROR_PACIFIST, []) ]+      -- for spawned and summoned monsters++rosterCrawlSurvival =+  [ ( EXPLORER_AUTOMATED+    , [(-1, 3, HERO)] )+  , ( MONSTER_REPRESENTATIVE+    , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] )+  , ( ANIMAL_NARRATING+    , [(-5, 10, ANIMAL)] ) ]  -- explore unopposed for some time++rosterSafariSurvival =+  [ ( MONSTER_TOURIST_PASSIVE+    , [(-4, 15, MONSTER)] )+  , ( CONVICT_REPRESENTATIVE+    , [(-4, 3, CIVILIAN)] )+  , ( ANIMAL_MAGNIFICENT_NARRATING+    , [(-7, 20, MOBILE_ANIMAL)] )+  , ( ANIMAL_EXQUISITE+    , [(-10, 30, MOBILE_ANIMAL)] ) ]++rosterBattle =+  [ ( EXPLORER_TRAPPED+    , [(-5, 5, SOLDIER_HERO)] )+  , ( MONSTER_CAPTIVE+    , [(-5, 35, MOBILE_MONSTER)] )+  , ( ANIMAL_CAPTIVE+    , [(-5, 30, MOBILE_ANIMAL)] ) ]++rosterBattleDefense =+  [ ( EXPLORER_AUTOMATED_TRAPPED+    , [(-5, 5, SOLDIER_HERO)] )+  , ( MONSTER_CAPTIVE_NARRATING+    , [(-5, 35, MOBILE_MONSTER)] )+  , ( ANIMAL_CAPTIVE+    , [(-5, 30, MOBILE_ANIMAL)] ) ]++rosterBattleSurvival =+  [ ( EXPLORER_AUTOMATED_TRAPPED+    , [(-5, 5, SOLDIER_HERO)] )+  , ( MONSTER_CAPTIVE+    , [(-5, 35, MOBILE_MONSTER)] )+  , ( ANIMAL_CAPTIVE_NARRATING+    , [(-5, 30, MOBILE_ANIMAL)] ) ]++rosterDefense =+  [ ( EXPLORER_AUTOMATED+    , [(-1, 3, HERO)] )+  , ( MONSTER_ANTI+    , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] )+  , ( ANIMAL_REPRESENTATIVE+    , [ (-1, 1 + 1 `d` 2, ANIMAL)+      , (-10, 100, MOBILE_ANIMAL) ] ) ]++rosterDefenseEmpty =+  [ ( MONSTER_ANTI_PACIFIST+    , [(-4, 1, SCOUT_MONSTER)] )+  , (HORROR_PACIFIST, []) ]+      -- for spawned and summoned animals++cavesRaid, cavesBrawl, cavesCrawl, cavesShootout, cavesHunt, cavesFlight, cavesZoo, cavesAmbush, cavesSafari, cavesDig, cavesSee, cavesShort, cavesCrawlEmpty, cavesBattle :: Caves++cavesRaid = [([-2], [CAVE_RAID])]++cavesBrawl = [([-2], [CAVE_BRAWL])]++listCrawl :: [([Int], [GroupName CaveKind])]+listCrawl =+  [ ([-1], [CAVE_OUTERMOST])+  , ([-2], [CAVE_SHALLOW_ROGUE])+  , ([-3], [CAVE_EMPTY])+  , ([-4, -5, -6], [DEFAULT_RANDOM, CAVE_ROGUE, CAVE_ARENA])+  , ([-7, -8], [CAVE_ROGUE, CAVE_SMOKING])+  , ([-9], [CAVE_LABORATORY])+  , ([-10], [CAVE_MINE]) ]++cavesCrawl = listCrawl++cavesShootout = [([-5], [CAVE_SHOOTOUT])]++cavesHunt = [([-6], [CAVE_HUNT])]++cavesFlight = [([-7], [CAVE_FLIGHT])]++cavesZoo = [([-8], [CAVE_ZOO])]++cavesAmbush = [([-9], [CAVE_AMBUSH])]++cavesSafari = [ ([-4], [CAVE_SAFARI_1])+              , ([-7], [CAVE_SAFARI_2])+              , ([-10], [CAVE_SAFARI_3]) ]++cavesDig = concat $ zipWith (map . renumberCaves)+                            [0, -10 ..]+                            (replicate 100 listCrawl)++renumberCaves :: Int -> ([Int], [GroupName CaveKind])+              -> ([Int], [GroupName CaveKind])+renumberCaves offset (ns, l) = (map (+ offset) ns, l)++cavesSee = let numberCaves n c = ([n], [c])+           in zipWith numberCaves [-1, -2 ..]+              $ concatMap (replicate 10) allCaves++cavesShort = let numberCaves n c = ([n], [c])+             in zipWith numberCaves [-1, -2 ..]+                $ concatMap (replicate 100) $ take 7 allCaves++allCaves :: [GroupName CaveKind]+allCaves =+  [ CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_FLIGHT, CAVE_ZOO+  , CAVE_AMBUSH+  , CAVE_ROGUE, CAVE_LABORATORY, CAVE_EMPTY, CAVE_ARENA, CAVE_SMOKING+  , CAVE_NOISE, CAVE_MINE ]++cavesCrawlEmpty = cavesCrawl++cavesBattle = [([-5], [CAVE_BATTLE])]
GameDefinition/Content/PlaceKind.hs view
@@ -1,185 +1,1021 @@--- | Rooms, halls and passages for LambdaHack.-module Content.PlaceKind ( cdefs ) where--import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Content.PlaceKind--cdefs :: ContentDef PlaceKind-cdefs = ContentDef-  { getSymbol = psymbol-  , getName = pname-  , getFreq = pfreq-  , validate = validatePlaceKind-  , content =-      [rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillarC, pillar3, colonnade, colonnade2, colonnade3, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3]-  }-rect,        ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillarC, pillar3, colonnade, colonnade2, colonnade3, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3 :: PlaceKind--rect = PlaceKind  -- Valid for any nonempty area, hence low frequency.-  { psymbol  = 'r'-  , pname    = "room"-  , pfreq    = [("rogue", 100), ("ambush", 8)]-  , prarity  = [(1, 1)]-  , pcover   = CStretch-  , pfence   = FNone-  , ptopLeft = [ "--"-               , "|."-               ]-  , poverride = []-  }-ruin = PlaceKind-  { psymbol  = 'R'-  , pname    = "ruin"-  , pfreq    = [("ambush", 17), ("battle", 100)]-  , prarity  = [(1, 1)]-  , pcover   = CStretch-  , pfence   = FNone-  , ptopLeft = [ "--"-               , "|X"-               ]-  , poverride = []-  }-collapsed = PlaceKind-  { psymbol  = 'c'-  , pname    = "collapsed cavern"-  , pfreq    = [("noise", 1)]-  , prarity  = [(1, 1)]-  , pcover   = CStretch-  , pfence   = FNone-  , ptopLeft = [ "O"-               ]-  , poverride = []-  }-collapsed2 = collapsed-  { pfreq    = [("noise", 100), ("battle", 50)]-  , ptopLeft = [ "XXO"-               , "XOO"-               ]-  }-collapsed3 = collapsed-  { pfreq    = [("noise", 200), ("battle", 50)]-  , ptopLeft = [ "XXXO"-               , "XOOO"-               ]-  }-collapsed4 = collapsed-  { pfreq    = [("noise", 400), ("battle", 200)]-  , ptopLeft = [ "XXXO"-               , "XXXO"-               , "XOOO"-               ]-  }-pillar = PlaceKind-  { psymbol  = 'p'-  , pname    = "pillar room"-  , pfreq    = [("rogue", 1000)]  -- larger rooms require support pillars-  , prarity  = [(1, 1)]-  , pcover   = CStretch-  , pfence   = FNone-  , ptopLeft = [ "-----"-               , "|...."-               , "|.O.."-               , "|...."-               , "|...."-               ]-  , poverride = []-  }-pillarC = pillar-  { ptopLeft = [ "-----"-               , "|O..."-               , "|...."-               , "|...."-               , "|...."-               ]-  }-pillar3 = pillar-  { ptopLeft = [ "-----"-               , "|&.O."-               , "|...."-               , "|O..."-               , "|...."-               ]-  }-colonnade = PlaceKind-  { psymbol  = 'c'-  , pname    = "colonnade"-  , pfreq    = [("rogue", 60)]-  , prarity  = [(1, 1)]-  , pcover   = CAlternate-  , pfence   = FFloor-  , ptopLeft = [ "O."-               , ".O"-               ]-  , poverride = []-  }-colonnade2 = colonnade-  { ptopLeft = [ "O."-               , ".."-               ]-  }-colonnade3 = colonnade-  { pfreq    = [("rogue", 6)]-  , ptopLeft = [ ".."-               , ".O"-               ]-  }-lampPost = PlaceKind-  { psymbol  = 'l'-  , pname    = "lamp post"-  , pfreq    = [("ambush", 30), ("battle", 10)]-  , prarity  = [(1, 1)]-  , pcover   = CVerbatim-  , pfence   = FNone-  , ptopLeft = [ "X.X"-               , ".O."-               , "X.X"-               ]-  , poverride = [('O', "lampPostOver_O")]-  }-lampPost2 = lampPost-  { ptopLeft = [ "..."-               , ".O."-               , "..."-               ]-  }-lampPost3 = lampPost-  { ptopLeft = [ "XX.XX"-               , "X...X"-               , "..O.."-               , "X...X"-               , "XX.XX"-               ]-  }-lampPost4 = lampPost-  { ptopLeft = [ "X...X"-               , "....."-               , "..O.."-               , "....."-               , "X...X"-               ]-  }-treeShade = PlaceKind-  { psymbol  = 't'-  , pname    = "tree shade"-  , pfreq    = [("skirmish", 100)]-  , prarity  = [(1, 1)]-  , pcover   = CVerbatim-  , pfence   = FNone-  , ptopLeft = [ "sss"-               , "XOs"-               , "XXs"-               ]-  , poverride = [('O', "treeShadeOver_O"), ('s', "treeShadeOver_s")]-  }-treeShade2 = treeShade-  { ptopLeft = [ "sss"-               , "XOs"-               , "Xss"-               ]-  }-treeShade3 = treeShade-  { ptopLeft = [ "sss"-               , "sOs"-               , "XXs"-               ]+-- | Definitions of place kinds. Every room in the game is an instantiated+-- place kind.+module Content.PlaceKind+  ( -- * Group name patterns+    pattern ROGUE, pattern LABORATORY, pattern ZOO, pattern BRAWL, pattern SHOOTOUT, pattern ARENA, pattern FLIGHT, pattern AMBUSH, pattern BATTLE, pattern NOISE, pattern MINE, pattern EMPTY+  , pattern INDOOR_ESCAPE_DOWN, pattern INDOOR_ESCAPE_UP, pattern OUTDOOR_ESCAPE_DOWN, pattern TINY_STAIRCASE, pattern OPEN_STAIRCASE, pattern CLOSED_STAIRCASE, pattern WALLED_STAIRCASE, pattern GATED_TINY_STAIRCASE, pattern GATED_OPEN_STAIRCASE, pattern GATED_CLOSED_STAIRCASE, pattern OUTDOOR_TINY_STAIRCASE, pattern OUTDOOR_CLOSED_STAIRCASE, pattern OUTDOOR_WALLED_STAIRCASE+  , groupNamesSingleton, groupNames+  , -- * Content+    content+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T++import Game.LambdaHack.Content.PlaceKind+import Game.LambdaHack.Content.TileKind (TileKind)+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal++import Content.TileKind hiding (content, groupNames, groupNamesSingleton)++-- * Group name patterns++groupNamesSingleton :: [GroupName PlaceKind]+groupNamesSingleton = []++-- TODO: if we stick to the current system of generating extra kinds and their+-- group names, let's also add the generated group names to @groupNames@.+groupNames :: [GroupName PlaceKind]+groupNames =+       [ROGUE, LABORATORY, ZOO, BRAWL, SHOOTOUT, ARENA, FLIGHT, AMBUSH, BATTLE, NOISE, MINE, EMPTY]+    ++ [INDOOR_ESCAPE_DOWN, INDOOR_ESCAPE_UP, OUTDOOR_ESCAPE_DOWN, TINY_STAIRCASE, OPEN_STAIRCASE, CLOSED_STAIRCASE, WALLED_STAIRCASE]+    ++ fst generatedStairs++pattern ROGUE, LABORATORY, ZOO, BRAWL, SHOOTOUT, ARENA, FLIGHT, AMBUSH, BATTLE, NOISE, MINE, EMPTY :: GroupName PlaceKind++pattern INDOOR_ESCAPE_DOWN, INDOOR_ESCAPE_UP, OUTDOOR_ESCAPE_DOWN, TINY_STAIRCASE, OPEN_STAIRCASE, CLOSED_STAIRCASE, WALLED_STAIRCASE, GATED_TINY_STAIRCASE, GATED_OPEN_STAIRCASE, GATED_CLOSED_STAIRCASE, OUTDOOR_TINY_STAIRCASE, OUTDOOR_CLOSED_STAIRCASE, OUTDOOR_WALLED_STAIRCASE :: GroupName PlaceKind++pattern ROGUE = GroupName "rogue"+pattern LABORATORY = GroupName "laboratory"+pattern ZOO = GroupName "zoo"+pattern BRAWL = GroupName "brawl"+pattern SHOOTOUT = GroupName "shootout"+pattern ARENA = GroupName "arena"+pattern FLIGHT = GroupName "flight"+pattern AMBUSH = GroupName "ambush"+pattern BATTLE = GroupName "battle"+pattern NOISE = GroupName "noise"+pattern MINE = GroupName "mine"+pattern EMPTY = GroupName "empty"++pattern INDOOR_ESCAPE_DOWN = GroupName "indoor escape down"+pattern INDOOR_ESCAPE_UP = GroupName "indoor escape up"+pattern OUTDOOR_ESCAPE_DOWN = GroupName "outdoor escape down"+pattern TINY_STAIRCASE = GroupName "tiny staircase"+pattern OPEN_STAIRCASE = GroupName "open staircase"+pattern CLOSED_STAIRCASE = GroupName "closed staircase"+pattern WALLED_STAIRCASE = GroupName "walled staircase"++-- This is a rotten compromise, because these are synthesized below,+-- so typos can happen.+pattern GATED_TINY_STAIRCASE = GroupName "gated tiny staircase"+pattern GATED_OPEN_STAIRCASE = GroupName "gated open staircase"+pattern GATED_CLOSED_STAIRCASE = GroupName "gated closed staircase"+pattern OUTDOOR_TINY_STAIRCASE = GroupName "outdoor tiny staircase"+pattern OUTDOOR_CLOSED_STAIRCASE = GroupName "outdoor closed staircase"+pattern OUTDOOR_WALLED_STAIRCASE = GroupName "outdoor walled staircase"++-- * Content++content :: [PlaceKind]+content =+  [deadEnd, rect, rect2, rect3, rect4, rectWindows, glasshouse, glasshouse2, glasshouse3, pulpit, ruin, ruin2, collapsed, collapsed2, collapsed3, collapsed4, collapsed5, collapsed6, collapsed7, pillar, pillar2, pillar3, pillar4, pillar5, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, fogClump, fogClump2, smokeClump, smokeClump2, smokeClump3FGround, bushClump, bushClump2, escapeDown, escapeDown2, escapeDown3, escapeDown4, escapeDown5, staircase1, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircase18, staircase19, staircase20, staircase21, staircase22, staircase23, staircase24, staircase25, staircase26, staircase27, staircase28, staircase29, staircase30, staircase31, staircase32, staircase33, staircase34, staircase35, staircase36, staircase37]+  -- automatically generated+  ++ snd generatedStairs ++ generatedEscapes++deadEnd,    rect, rect2, rect3, rect4, rectWindows, glasshouse, glasshouse2, glasshouse3, pulpit, ruin, ruin2, collapsed, collapsed2, collapsed3, collapsed4, collapsed5, collapsed6, collapsed7, pillar, pillar2, pillar3, pillar4, pillar5, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, fogClump, fogClump2, smokeClump, smokeClump2, smokeClump3FGround, bushClump, bushClump2, escapeDown, escapeDown2, escapeDown3, escapeDown4, escapeDown5, staircase1, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircase18, staircase19, staircase20, staircase21, staircase22, staircase23, staircase24, staircase25, staircase26, staircase27, staircase28, staircase29, staircase30, staircase31, staircase32, staircase33, staircase34, staircase35, staircase36, staircase37 :: PlaceKind++staircase :: PlaceKind  -- template++staircaseBasic :: [PlaceKind]+staircaseBasic = [staircase1, staircase2, staircase3, staircase4, staircase5, staircase6, staircase7, staircase8, staircase9, staircase10, staircase11, staircase12, staircase13, staircase14, staircase15, staircase16, staircase17, staircase18, staircase19, staircase20, staircase21, staircase22, staircase23, staircase24, staircase25, staircase26, staircase27, staircase28, staircase29, staircase30, staircase31, staircase32, staircase33, staircase34, staircase35, staircase36, staircase37]++generatedStairs :: ([GroupName PlaceKind], [PlaceKind])+generatedStairs =+  let gatedStairs = map switchStaircaseToGated staircaseBasic+      outdoorStairs = map switchStaircaseToOutdoor staircaseBasic+      stairsAll = staircaseBasic ++ gatedStairs ++ outdoorStairs+      upStairs = map switchStaircaseToUp stairsAll+      downStairs = map switchStaircaseToDown stairsAll+      genStairs = gatedStairs ++ outdoorStairs ++ upStairs ++ downStairs+  in ( nub $ sort $ concatMap (map fst . pfreq) genStairs+     , genStairs )++escapeDownBasic :: [PlaceKind]+escapeDownBasic =+  [escapeDown, escapeDown2, escapeDown3, escapeDown4, escapeDown5]++generatedEscapes :: [PlaceKind]+generatedEscapes =+  let upEscapes = map switchEscapeToUp escapeDownBasic+      outdoorEscapes = map switchEscapeToOutdoorDown escapeDownBasic+  in upEscapes ++ outdoorEscapes++-- The dots below are @'\x00B7'@, as defined in `TileKind.floorSymbol`.+defaultLegendLit :: EM.EnumMap Char (GroupName TileKind)+defaultLegendLit = EM.fromList+  [ (' ', FILLER_WALL)+  , ('|', S_WALL_LIT)+  , ('-', S_WALL_HORIZONTAL_LIT)+  , ('0', S_PILLAR)+  , ('&', S_RUBBLE_PILE)+  , ('<', TILE_INDOOR_ESCAPE_UP)+  , ('>', TILE_INDOOR_ESCAPE_DOWN)+  , ('·', FLOOR_ACTOR_ITEM_LIT)+  , ('~', S_SHALLOW_WATER_LIT)+  , ('I', SIGNBOARD) ]++defaultLegendDark :: EM.EnumMap Char (GroupName TileKind)+defaultLegendDark = EM.fromList+  [ (' ', FILLER_WALL)+  , ('|', S_WALL_DARK)+  , ('-', S_WALL_HORIZONTAL_DARK)+  , ('0', S_PILLAR)+  , ('&', S_RUBBLE_PILE)+  , ('<', TILE_INDOOR_ESCAPE_UP)+  , ('>', TILE_INDOOR_ESCAPE_DOWN)+  , ('·', FLOOR_ACTOR_ITEM_DARK)+  , ('~', S_SHALLOW_WATER_DARK)+  , ('I', SIGNBOARD) ]++deadEnd = PlaceKind  -- needs to have index 0+  { pname    = "a dead end"+  , pfreq    = []+  , prarity  = []+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = ["·"]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+rect = PlaceKind  -- Valid for any nonempty area, hence low frequency.+  { pname    = "a chamber"+  , pfreq    = [(ROGUE, 30), (LABORATORY, 10)]+  , prarity  = [(1, 10), (10, 6)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "--"+               , "|·"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+rect2 = rect+  { pname    = "a pen"+  , pfreq    = [(ZOO, 3)]+  }+rect3 = overridePlaceKind [ ('|', S_WALL_LIT)  -- visible from afar+                          , ('-', S_WALL_HORIZONTAL_LIT) ] $ rect+  { pname    = "a shed"+  , pfreq    = [(BRAWL, 10), (SHOOTOUT, 1)]+  }+rect4 = rect3+  { pname    = "cabinet"+  , pfreq    = [(ARENA, 10)]+  }+rectWindows = override2PlaceKind+                [ ('=', RECT_WINDOWS_HORIZONTAL_DARK)+                , ('!', RECT_WINDOWS_VERTICAL_DARK) ]+                [ ('=', RECT_WINDOWS_HORIZONTAL_LIT)+                , ('!', RECT_WINDOWS_VERTICAL_LIT) ] $ PlaceKind+  { pname    = "a hut"+  , pfreq    = [(FLIGHT, 10), (AMBUSH, 7)]+  , prarity  = [(1, 10), (10, 10)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "-="+               , "!·"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+glasshouse = overridePlaceKind+               [ ('=', GLASSHOUSE_HORIZONTAL_LIT)  -- visible from afar+               , ('!', GLASSHOUSE_VERTICAL_LIT) ] $ PlaceKind+  { pname    = "a glasshouse"+  , pfreq    = [(SHOOTOUT, 4)]+  , prarity  = [(1, 10), (10, 7)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "=="+               , "!·"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+glasshouse2 = override2PlaceKind [ ('=', GLASSHOUSE_HORIZONTAL_DARK)+                                 , ('!', GLASSHOUSE_VERTICAL_DARK) ]+                                 [ ('=', GLASSHOUSE_HORIZONTAL_LIT)+                                 , ('!', GLASSHOUSE_VERTICAL_LIT) ] $ glasshouse+  { pname    = "a glass cage"+  , pfreq    = [(ZOO, 10)]+  }+glasshouse3 = glasshouse+  { pname    = "a reading room"+  , pfreq    = [(ARENA, 40)]+  }+pulpit = overridePlaceKind [ ('=', GLASSHOUSE_HORIZONTAL_LIT)+                           , ('!', GLASSHOUSE_VERTICAL_LIT)+                           , ('0', S_PULPIT) ] $ PlaceKind+           -- except for floor, all will be lit, regardless of night/dark; OK+  { pname    = "a stand dais"+  , pfreq    = [(ARENA, 200), (ZOO, 200)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FGround+  , ptopLeft = [ "==·"+               , "!··"+               , "··0"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+ruin = PlaceKind+  { pname    = "ruins"+  , pfreq    = [(BATTLE, 330)]+  , prarity  = [(1, 1)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "--"+               , "|X"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+ruin2 = overridePlaceKind [ ('|', S_WALL_LIT)  -- visible from afar+                          , ('-', S_WALL_HORIZONTAL_LIT) ] $ ruin+  { pname    = "blasted walls"+  , pfreq    = [(AMBUSH, 50)]+  }+collapsed = PlaceKind+  { pname    = "a collapsed cavern"+  , pfreq    = [(NOISE, 1)]+      -- no point taking up space if very little space taken,+      -- but if no other place can be generated, a failsafe is useful+  , prarity  = [(1, 1)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "0"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+collapsed2 = collapsed+  { pfreq    = [(NOISE, 1000), (BATTLE, 200)]+  , ptopLeft = [ "X0"+               , "00"+               ]+  }+collapsed3 = collapsed+  { pfreq    = [(NOISE, 2000), (BATTLE, 200)]+  , ptopLeft = [ "XX0"+               , "000"+               ]+  }+collapsed4 = collapsed+  { pfreq    = [(NOISE, 2000), (BATTLE, 200)]+  , ptopLeft = [ "XXX0"+               , "0000"+               ]+  }+collapsed5 = collapsed+  { pfreq    = [(NOISE, 3000), (BATTLE, 500)]+  , ptopLeft = [ "XX0"+               , "X00"+               , "000"+               ]+  }+collapsed6 = collapsed+  { pfreq    = [(NOISE, 4000), (BATTLE, 1000)]+  , ptopLeft = [ "XXX0"+               , "X000"+               , "0000"+               ]+  }+collapsed7 = collapsed+  { pfreq    = [(NOISE, 4000), (BATTLE, 1000)]+  , ptopLeft = [ "XXX0"+               , "XX00"+               , "0000"+               ]+  }+pillar = PlaceKind+  { pname    = "a hall"+  , pfreq    = [(ROGUE, 600), (LABORATORY, 2000)]+  , prarity  = [(1, 1)]+  , pcover   = CStretch+  , pfence   = FNone+  -- Larger rooms require support pillars.+  , ptopLeft = [ "----"+               , "|···"+               , "|·0·"+               , "|···"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+pillar2 = pillar+  { pfreq    = [(ROGUE, 60), (LABORATORY, 200)]+  , ptopLeft = [ "----"+               , "|0··"+               , "|···"+               , "|···"+               ]+  }+pillar3 = pillar+  { pfreq    = [(ROGUE, 8000), (LABORATORY, 25000)]+  , ptopLeft = [ "-----"+               , "|0···"+               , "|····"+               , "|··0·"+               , "|····"+               ]+  }+pillar4 = overridePlaceKind [('&', CACHE)] $ pillar+  { pname    = "an exquisite hall"+  , pfreq    = [(ROGUE, 30000), (LABORATORY, 100000)]+  , ptopLeft = [ "-----"+               , "|&·0·"+               , "|····"+               , "|0·0·"+               , "|····"+               ]+  }+pillar5 = overridePlaceKind [('&', CACHE)] $ pillar+  { pname    = "a decorated hall"+  , pfreq    = [(ROGUE, 30000), (LABORATORY, 100000)]+  , ptopLeft = [ "-----"+               , "|&·0·"+               , "|····"+               , "|0···"+               , "|····"+               ]+  }+colonnade = PlaceKind+  { pname    = "a colonnade"+  , pfreq    = [ (ROGUE, 3), (ARENA, 20), (LABORATORY, 2)+               , (EMPTY, 10000), (MINE, 1000), (BRAWL, 4)+               , (FLIGHT, 40), (AMBUSH, 40) ]+  , prarity  = [(1, 10), (10, 10)]+  , pcover   = CAlternate+  , pfence   = FFloor+  , ptopLeft = [ "0·"+               , "··"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+colonnade2 = colonnade+  { prarity  = [(1, 15), (10, 15)]+  , ptopLeft = [ "0·"+               , "·0"+               ]+  }+colonnade3 = colonnade+  { prarity  = [(1, 800), (10, 800)]+  , ptopLeft = [ "··0"+               , "·0·"+               , "0··"+               ]+  }+colonnade4 = colonnade+  { prarity  = [(1, 200), (10, 200)]+  , ptopLeft = [ "0··"+               , "·0·"+               , "··0"+               ]+  }+colonnade5 = colonnade+  { prarity  = [(1, 10), (10, 10)]+  , ptopLeft = [ "0··"+               , "··0"+               ]+  }+colonnade6 = colonnade+  { prarity  = [(1, 100), (10, 100)]+  , ptopLeft = [ "0·"+               , "··"+               , "·0"+               ]+  }+lampPost = overridePlaceKind [ ('0', S_LAMP_POST)+                             , ('·', S_FLOOR_ACTOR_LIT) ] $ PlaceKind+  { pname    = "a lamp-lit area"+  , pfreq    = [(FLIGHT, 200), (AMBUSH, 200), (ZOO, 100), (BATTLE, 100)]+  , prarity  = [(1, 1)]+  , pcover   = CVerbatim+  , pfence   = FNone+  , ptopLeft = [ "X·X"+               , "·0·"+               , "X·X"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+lampPost2 = lampPost+  { ptopLeft = [ "···"+               , "·0·"+               , "···"+               ]+  }+lampPost3 = lampPost+  { pfreq    = [ (FLIGHT, 3000), (AMBUSH, 3000), (ZOO, 50)+               , (BATTLE, 110) ]+  , ptopLeft = [ "XX·XX"+               , "X···X"+               , "··0··"+               , "X···X"+               , "XX·XX"+               ]+  }+lampPost4 = lampPost+  { pfreq    = [(FLIGHT, 3000), (AMBUSH, 3000), (ZOO, 50), (BATTLE, 60)]+  , ptopLeft = [ "X···X"+               , "·····"+               , "··0··"+               , "·····"+               , "X···X"+               ]+  }+treeShade = override2PlaceKind [ ('0', S_TREE_DARK)+                               , ('s', TREE_SHADE_WALKABLE_DARK) ]+                               [ ('0', S_TREE_LIT)+                               , ('s', TREE_SHADE_WALKABLE_LIT) ] $+            overridePlaceKind [('·', S_SHADED_GROUND)] $ PlaceKind+  { pname    = "a tree shade"+  , pfreq    = [(BRAWL, 1000)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "··s"+               , "s0·"+               , "Xs·"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+fogClump = override2PlaceKind [('f', FOG_CLUMP_DARK)]+                              [('f', FOG_CLUMP_LIT)] $+           overridePlaceKind [(';', S_FOG_LIT)] $ PlaceKind+  { pname    = "a foggy patch"+  , pfreq    = [(SHOOTOUT, 150), (EMPTY, 15)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "f;"+               , ";f"+               , ";X"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+fogClump2 = fogClump+  { pfreq    = [(SHOOTOUT, 500), (EMPTY, 50)]+  , ptopLeft = [ "X;f"+               , "f;f"+               , ";;f"+               , "Xff"+               ]+  }+smokeClump = override2PlaceKind [ ('f', SMOKE_CLUMP_DARK)+                                , ('·', S_FLOOR_ACTOR_DARK) ]+                                [ ('f', SMOKE_CLUMP_LIT)+                                , ('·', S_FLOOR_ACTOR_LIT) ] $+             overridePlaceKind [(';', S_SMOKE_LIT)] $ PlaceKind+  { pname    = "a smoky patch"+  , pfreq    = [(ZOO, 50)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "f;"+               , ";f"+               , ";X"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+smokeClump2 = smokeClump+  { pfreq    = [(ZOO, 500)]+  , ptopLeft = [ "X;f"+               , "f;f"+               , ";;f"+               , "Xff"+               ]+  }+smokeClump3FGround = smokeClump+  { pname    = "a burned out area"+  , pfreq    = [(LABORATORY, 150)]+  , prarity  = [(1, 1)]+  , pcover   = CVerbatim+  , pfence   = FGround+  , ptopLeft = [ ";f;"+               , "f·f"+               , "f·f"+               , ";f;"+               ]+      -- should not be used in caves with trails, because bushes should+      -- not grow over such artificial trails+  }+bushClump = override2PlaceKind [('f', BUSH_CLUMP_DARK)]+                               [('f', BUSH_CLUMP_LIT)] $+            overridePlaceKind [(';', S_BUSH_LIT)] $ PlaceKind+  { pname    = "a bushy patch"+  , pfreq    = [(SHOOTOUT, 40)]+  , prarity  = [(1, 1)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "Xf"  -- one sure exit needed not to block a corner+               , ";X"+               , ";;"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+      -- should not be used in caves with trails, because bushes can't+      -- grow over such artificial trails+  }+bushClump2 = bushClump+  { pfreq    = [(SHOOTOUT, 80)]+  , ptopLeft = [ "Xf"  -- one sure exit needed not to block a corner+               , ";X"+               , ";X"+               , ";;"+               ]+  }+escapeDown = overridePlaceKind [ ('|', S_WALL_LIT)  -- visible from afar+                               , ('-', S_WALL_HORIZONTAL_LIT) ] $ PlaceKind+  { pname    = "an escape down"+  , pfreq    = [(INDOOR_ESCAPE_DOWN, 1)]+  , prarity  = [(1, 1)]+  , pcover   = CVerbatim+  , pfence   = FGround+  , ptopLeft = [ ">"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+escapeDown2 = escapeDown+  { pfreq    = [(INDOOR_ESCAPE_DOWN, 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "0·0"+               , "·>·"+               , "0·0"+               ]+  }+escapeDown3 = escapeDown+  { pfreq    = [(INDOOR_ESCAPE_DOWN, 2000)]+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|0·0|"+               , "|·>·|"+               , "|0·0|"+               , "-----"+               ]+  }+escapeDown4 = escapeDown+  { pfreq    = [(INDOOR_ESCAPE_DOWN, 1000)]+  , pcover   = CMirror+  , pfence   = FFloor+  , ptopLeft = [ "0··"+               , "·>·"+               , "··0"+               ]+  }+escapeDown5 = escapeDown+  { pfreq    = [(INDOOR_ESCAPE_DOWN, 2000)]+  , pcover   = CMirror+  , pfence   = FNone+  , ptopLeft = [ "-----"+               , "|0··|"+               , "|·>·|"+               , "|0·0|"+               , "-----"+               ]+  }+staircase = overridePlaceKind [ ('<', STAIRCASE_UP)+                              , ('>', STAIRCASE_DOWN)+                              , ('|', S_WALL_LIT)  -- visible from afar+                              , ('-', S_WALL_HORIZONTAL_LIT) ] $ PlaceKind+  { pname    = "a staircase"+  , pfreq    = [(TINY_STAIRCASE, 1)]  -- no cover when arriving; low freq+  , prarity  = [(1, 100), (10, 100)]+  , pcover   = CVerbatim+  , pfence   = FGround+  , ptopLeft = [ "<·>"+               ]+  , plegendDark = defaultLegendDark+  , plegendLit = defaultLegendLit+  }+staircase1 = staircase+  { prarity  = [(1, 1)]  -- no cover when arriving; so low rarity+  }+staircase2 = staircase+  { pfreq    = [(TINY_STAIRCASE, 3)]+  , prarity  = [(1, 1)]+  , pfence   = FGround+  , ptopLeft = [ "·<·>·"+               ]+  }+staircase3 = staircase+  { prarity  = [(1, 1)]+  , pfence   = FFloor+  }+staircase4 = staircase2+  { pfence   = FFloor+  , prarity  = [(1, 1)]+  }+staircase5 = staircase+  { pfreq    = [(OPEN_STAIRCASE, 200)]  -- no cover, open+  , pfence   = FGround+  , ptopLeft = [ "0·0"+               , "···"+               , "<·>"+               , "···"+               , "0·0"+               ]+  }+staircase6 = staircase+  { pfreq    = [(OPEN_STAIRCASE, 300)]+  , pfence   = FGround+  , ptopLeft = [ "0·0·0"+               , "·····"+               , "·<·>·"+               , "·····"+               , "0·0·0"+               ]+  }+staircase7 = staircase+  { pfreq    = [(OPEN_STAIRCASE, 500)]+  , pfence   = FGround+  , ptopLeft = [ "0·0·0·0"+               , "·······"+               , "0·<·>·0"+               , "·······"+               , "0·0·0·0"+               ]+  }+staircase8 = staircase+  { pfreq    = [(OPEN_STAIRCASE, 2000)]+  , pfence   = FGround+  , ptopLeft = [ "·0·I·0·"+               , "0·····0"+               , "··<·>··"+               , "0·····0"+               , "·0·0·0·"+               ]+  }+staircase9 = staircase+  { pfreq    = [(OPEN_STAIRCASE, 500)]+  , pfence   = FGround+  , ptopLeft = [ "0·······0"+               , "···<·>···"+               , "0·······0"+               ]+  }+staircase10 = staircase+  { pfreq    = [(OPEN_STAIRCASE, 500)]+  , pfence   = FGround+  , ptopLeft = [ "0·····0"+               , "··<·>··"+               , "0·····0"+               ]+  }+staircase11 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 2000)]  -- weak cover, low freq+  , pfence   = FFloor+  , ptopLeft = [ "·0·"+               , "0·0"+               , "···"+               , "<·>"+               , "···"+               , "0·0"+               , "·0·"+               ]+  }+staircase12 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 4000)]+  , pfence   = FFloor+  , ptopLeft = [ "·0·0·"+               , "0·0·0"+               , "·····"+               , "·<·>·"+               , "·····"+               , "0·0·0"+               , "·0·0·"+               ]+  }+staircase13 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 6000)]+  , pfence   = FFloor+  , ptopLeft = [ "·0·0·0·"+               , "0·0·0·0"+               , "·······"+               , "0·<·>·0"+               , "·······"+               , "0·0·0·0"+               , "·0·0·0·"+               ]+  }+staircase14 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 10000)]+  , pfence   = FFloor+  , ptopLeft = [ "0·0·0·0"+               , "·0·0·0·"+               , "0·····0"+               , "··<·>··"+               , "0·····0"+               , "·0·0·0·"+               , "0·0·0·0"+               ]+  }+staircase15 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 20000)]+  , pfence   = FFloor+  , ptopLeft = [ "·0·0·0·0·"+               , "0·0·0·0·0"+               , "·0·····0·"+               , "0··<·>··0"+               , "·0·····0·"+               , "0·0·0·0·0"+               , "·0·0·0·0·"+               ]+  }+staircase16 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 20000)]+  , pfence   = FFloor+  , ptopLeft = [ "0·0·0·0·0"+               , "·0·0·0·0·"+               , "0·······0"+               , "·0·<·>·0·"+               , "0·······0"+               , "·0·0·0·0·"+               , "0·0·0·0·0"+               ]+  }+staircase17 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 20000)]+  , pfence   = FFloor+  , ptopLeft = [ "0·0·0·0·0·0"+               , "·0·0·0·0·0·"+               , "0·0·····0·0"+               , "·0··<·>··0·"+               , "0·0·····0·0"+               , "·0·0·0·0·0·"+               , "0·0·0·0·0·0"+               ]+  }+staircase18 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 80000)]+  , pfence   = FFloor+  , ptopLeft = [ "··0·0·0·0··"+               , "·0·0·0·0·0·"+               , "0·0·····0·0"+               , "·0··<·>··0·"+               , "0·0·····0·0"+               , "·0·0·0·0·0·"+               , "··0·0·0·0··"+               ]+  }+staircase19 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 20000)]+  , pfence   = FFloor+  , ptopLeft = [ "·0·0·0·0·0·"+               , "0·0·0·0·0·0"+               , "·0·······0·"+               , "0·0·<·>·0·0"+               , "·0·······0·"+               , "0·0·0·0·0·0"+               , "·0·0·0·0·0·"+               ]+  }+staircase20 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 5000)]+  , pfence   = FFloor+  , ptopLeft = [ "·0·0·0·0·0·"+               , "0·0·····0·0"+               , "·0··<·>··0·"+               , "0·0·····0·0"+               , "·0·0·I·0·0·"+               ]+  }+staircase21 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 5000)]+  , pfence   = FFloor+  , ptopLeft = [ "0·0·I·0·0"+               , "·0·····0·"+               , "0··<·>··0"+               , "·0·····0·"+               , "0·0·0·0·0"+               ]+  }+staircase22 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 2000)]+  , pfence   = FFloor+  , ptopLeft = [ "0·0·····0·0"+               , "·0··<·>··0·"+               , "0·0·····0·0"+               ]+  }+staircase23 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "·0·······0·"+               , "0·0·<·>·0·0"+               , "·0·······0·"+               ]+  }+staircase24 = staircase+  { pfreq    = [(CLOSED_STAIRCASE, 1000)]+  , pfence   = FFloor+  , ptopLeft = [ "·0·····0·"+               , "0··<·>··0"+               , "·0·····0·"+               ]+  }+staircase25 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 10)]+  , pfence   = FNone+  , ptopLeft = [ "-------"+               , "|·····|"+               , "|·<·>·|"+               , "|·····|"+               , "-------"+               ]+  }+staircase26 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 50)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|·······|"+               , "|··<·>··|"+               , "|·······|"+               , "---------"+               ]+  }+staircase27 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 100)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|0·····0|"+               , "|··<·>··|"+               , "|0·····0|"+               , "---------"+               ]+  }+staircase28 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-------"+               , "|·····|"+               , "|·····|"+               , "|·<·>·|"+               , "|·····|"+               , "|·····|"+               , "-------"+               ]+  }+staircase29 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-------"+               , "|0···0|"+               , "|·····|"+               , "|·<·>·|"+               , "|·····|"+               , "|0···0|"+               , "-------"+               ]+  }+staircase30 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 1000)]+  , pfence   = FNone+  , ptopLeft = [ "-------"+               , "|0·0·0|"+               , "|·····|"+               , "|·<·>·|"+               , "|·····|"+               , "|0·0·0|"+               , "-------"+               ]+  }+staircase31 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 2000)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|·······|"+               , "|·······|"+               , "|··<·>··|"+               , "|·······|"+               , "|·······|"+               , "---------"+               ]+  }+staircase32 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 5000)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|0·····0|"+               , "|·······|"+               , "|··<·>··|"+               , "|·······|"+               , "|0·····0|"+               , "---------"+               ]+  }+staircase33 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 5000)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|0·0·0·0|"+               , "|·······|"+               , "|0·<·>·0|"+               , "|·······|"+               , "|0·0·0·0|"+               , "---------"+               ]+  }+staircase34 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 5000)]+  , pfence   = FNone+  , ptopLeft = [ "---------"+               , "|·0·0·0·|"+               , "|0·····0|"+               , "|··<·>··|"+               , "|0·····0|"+               , "|·0·I·0·|"+               , "---------"+               ]+  }+staircase35 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 200)]+  , pfence   = FNone+  , ptopLeft = [ "-----------"+               , "|·········|"+               , "|···<·>···|"+               , "|·········|"+               , "-----------"+               ]+  }+staircase36 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 500)]+  , pfence   = FNone+  , ptopLeft = [ "-----------"+               , "|·0·····0·|"+               , "|0··<·>··0|"+               , "|·0·····0·|"+               , "-----------"+               ]+  }+staircase37 = staircase+  { pfreq    = [(WALLED_STAIRCASE, 500)]+  , pfence   = FNone+  , ptopLeft = [ "-----------"+               , "|0·······0|"+               , "|·0·<·>·0·|"+               , "|0·······0|"+               , "-----------"+               ]+  }++switchStaircaseToUp :: PlaceKind -> PlaceKind+switchStaircaseToUp s = override2PlaceKind [('>', STAIR_TERMINAL_DARK)]+                                           [('>', STAIR_TERMINAL_LIT)] $ s+  { pname     = pname s <+> "up"+  , pfreq     = renameFreqs (<+> "up") $ pfreq s+  }++switchStaircaseToDown :: PlaceKind -> PlaceKind+switchStaircaseToDown s = override2PlaceKind [('<', STAIR_TERMINAL_DARK)]+                                             [('<', STAIR_TERMINAL_LIT)] $ s+  { pname     = pname s <+> "down"+  , pfreq     = renameFreqs (<+> "down") $ pfreq s+  }++overrideGated :: [(Char, GroupName TileKind)]+overrideGated =+  [ ('<', GATED_STAIRCASE_UP), ('>', GATED_STAIRCASE_DOWN)+  , ('|', S_WALL_LIT), ('-', S_WALL_HORIZONTAL_LIT) ]  -- visible from afar++switchStaircaseToGated :: PlaceKind -> PlaceKind+switchStaircaseToGated s = overridePlaceKind overrideGated $ s+  { pname     = T.unwords $ "a gated" : tail (T.words (pname s))+  , pfreq     = renameFreqs ("gated" <+>) $ pfreq s+  }++overrideOutdoor :: [(Char, GroupName TileKind)]+overrideOutdoor =+  [ ('<', STAIRCASE_OUTDOOR_UP), ('>', STAIRCASE_OUTDOOR_DOWN)+  , ('|', S_WALL_LIT), ('-', S_WALL_HORIZONTAL_LIT) ]  -- visible from afar++switchStaircaseToOutdoor :: PlaceKind -> PlaceKind+switchStaircaseToOutdoor s = overridePlaceKind overrideOutdoor $ s+  { pname     = "an outdoor area exit"+  , pfreq     = renameFreqs ("outdoor" <+>) $ pfreq s+  }++switchEscapeToUp :: PlaceKind -> PlaceKind+switchEscapeToUp s = overridePlaceKind [('>', TILE_INDOOR_ESCAPE_UP)] $ s+  { pname     = "an escape up"+  , pfreq     = map (\(_, n) -> (INDOOR_ESCAPE_UP, n)) $ pfreq s+  }++switchEscapeToOutdoorDown :: PlaceKind -> PlaceKind+switchEscapeToOutdoorDown s = overridePlaceKind+                                [('>', TILE_OUTDOOR_ESCAPE_DOWN)] $ s+  { pname     = "outdoor escape route"+  , pfreq     = map (\(_, n) -> (OUTDOOR_ESCAPE_DOWN, n)) $ pfreq s   }
GameDefinition/Content/RuleKind.hs view
@@ -1,75 +1,77 @@ {-# LANGUAGE TemplateHaskell #-}--- | Game rules and assorted game setup data for LambdaHack.-module Content.RuleKind ( cdefs ) where+-- | Game rules and assorted game setup data.+module Content.RuleKind+  ( standardRules+  ) where -import Language.Haskell.TH.Syntax-import System.FilePath+import Prelude () +import Game.LambdaHack.Core.Prelude++import qualified Data.Ini.Reader as Ini+import           Instances.TH.Lift ()+import           Language.Haskell.TH.Syntax+import           System.FilePath+import           System.IO+  (IOMode (ReadMode), hGetContents, hSetEncoding, openFile, utf8)+ -- Cabal-import qualified Paths_LambdaHack as Self (getDataFileName, version)+import qualified Paths_LambdaHack as Self (version) -import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind (ItemSymbolsUsedInEngine (..)) import Game.LambdaHack.Content.RuleKind--cdefs :: ContentDef RuleKind-cdefs = ContentDef-  { getSymbol = rsymbol-  , getName = rname-  , getFreq = rfreq-  , validate = validateRuleKind-  , content =-      [standard]-  }+import Game.LambdaHack.Definition.DefsInternal -standard :: RuleKind-standard = RuleKind-  { rsymbol        = 's'-  , rname          = "standard LambdaHack ruleset"-  , rfreq          = [("standard", 100)]-  -- Check whether one position is accessible from another.-  -- Precondition: the two positions are next to each other-  -- and the target tile is walkable. For LambdaHack we forbid-  -- diagonal movement to and from doors.-  , raccessible    = Nothing-  , raccessibleDoor =-      Just $ \spos tpos -> not $ isDiagonal $ spos `vectorToFrom` tpos-  , rtitle         = "LambdaHack"-  , rpathsDataFile = Self.getDataFileName-  , rpathsVersion  = Self.version+standardRules :: RuleContent+standardRules = RuleContent+  { rtitle = "LambdaHack"+  , rWidthMax = 80+  , rHeightMax = 21+  , rexeVersion = Self.version   -- The strings containing the default configuration file   -- included from config.ui.default.-  , rcfgUIName = "config.ui"+  , rcfgUIName = "config.ui" <.> "ini"   , rcfgUIDefault = $(do       let path = "GameDefinition" </> "config.ui" <.> "default"       qAddDependentFile path-      x <- qRunIO (readFile path)-      lift x)-  -- ASCII art for the Main Menu. Only pure 7-bit ASCII characters are-  -- allowed. The picture should be exactly 24 rows by 80 columns,-  -- plus an extra frame (of any characters) that is ignored.-  -- For a different screen size, the picture is centered and the outermost-  -- rows and columns cloned. When displayed in the Main Menu screen,-  -- it's overwritten with the game version string and keybinding strings.-  -- The game version string begins and ends with a space and is placed-  -- in the very bottom right corner. The keybindings overwrite places-  -- marked with 25 left curly brace signs '{' in a row. The sign is forbidden-  -- everywhere else. A specific number of such places with 25 left braces-  -- are required, at most one per row, and all are overwritten-  -- with text that is flushed left and padded with spaces.-  -- The Main Menu is displayed dull white on black.-  -- TODO: Show highlighted keybinding in inverse video or bright white on grey-  -- background. The spaces that pad keybindings are not highlighted.-  , rmainMenuArt = $(do-      let path = "GameDefinition/MainMenu.ascii"-      qAddDependentFile path-      x <- qRunIO (readFile path)-      lift x)-  , rfirstDeathEnds = False-  , rfovMode = Digital-  , rsaveBkpClips = 500-  , rleadLevelClips = 100-  , rscoresFile = "scores"-  , rsavePrefix = "save"-  , rsharedStash = True+      !s <- qRunIO $ do+        inputHandle <- openFile path ReadMode+        hSetEncoding inputHandle utf8+        hGetContents inputHandle+      let !cfgUIDefault =+            either (error . ("Ini.parse of default config" `showFailure`)) id+            $ Ini.parse s+      lift (s, cfgUIDefault))+  , rwriteSaveClips = 1000+  , rleadLevelClips = 50+  , rscoresFileName = "LambdaHack.scores"+  , rnearby = 20+  , rstairWordCarried = ["staircase"]  -- only one, so inert+  , ritemSymbols = ItemSymbolsUsedInEngine+      { rsymbolProjectile = toContentSymbol '|'+      , rsymbolLight      = toContentSymbol '('+      , rsymbolTool       = toContentSymbol '('+      , rsymbolSpecial    = toContentSymbol '*'+                              -- don't overuse; it clashes with projectiles+      , rsymbolGold       = toContentSymbol '$'+                              -- also gems+      , rsymbolNecklace   = toContentSymbol '"'+      , rsymbolRing       = toContentSymbol '='+      , rsymbolPotion     = toContentSymbol '!'+                              -- also concoction, bottle, jar, vial+      , rsymbolFlask      = toContentSymbol '!'+      , rsymbolScroll     = toContentSymbol '?'+                              -- also book, note, tablet, card+      , rsymbolTorsoArmor = toContentSymbol '['+      , rsymbolMiscArmor  = toContentSymbol '['+      , rsymbolClothes    = toContentSymbol '['+      , rsymbolShield     = toContentSymbol ']'+      , rsymbolPolearm    = toContentSymbol ')'+      , rsymbolEdged      = toContentSymbol ')'+      , rsymbolHafted     = toContentSymbol ')'+      , rsymbolWand       = toContentSymbol '/'+                              -- also magical rod, pistol, instrument+      , rsymbolFood       = toContentSymbol ','+          -- also body part; distinct enough from floor, which is middle dot+      }   }
GameDefinition/Content/TileKind.hs view
@@ -1,304 +1,871 @@--- | Terrain tiles for LambdaHack.-module Content.TileKind ( cdefs ) where+-- | Definitions of tile kinds. Every terrain tile in the game is+-- an instantiated tile kind.+module Content.TileKind+  ( -- * Group name patterns+    -- ** Used in CaveKind and perhaps elsewhere.+    pattern FILLER_WALL, pattern FLOOR_CORRIDOR_LIT, pattern FLOOR_CORRIDOR_DARK, pattern TRAIL_LIT, pattern SAFE_TRAIL_LIT, pattern LAB_TRAIL_LIT, pattern DAMP_FLOOR_LIT, pattern DAMP_FLOOR_DARK, pattern OUTDOOR_OUTER_FENCE, pattern DIRT_LIT, pattern DIRT_DARK, pattern FLOOR_ARENA_LIT, pattern FLOOR_ARENA_DARK+  , pattern EMPTY_SET_LIT, pattern EMPTY_SET_DARK, pattern NOISE_SET_LIT, pattern POWER_SET_LIT, pattern POWER_SET_DARK, pattern BATTLE_SET_LIT, pattern BATTLE_SET_DARK, pattern BRAWL_SET_LIT, pattern SHOOTOUT_SET_LIT, pattern ZOO_SET_LIT, pattern ZOO_SET_DARK, pattern FLIGHT_SET_LIT, pattern FLIGHT_SET_DARK, pattern AMBUSH_SET_LIT, pattern AMBUSH_SET_DARK, pattern ARENA_SET_LIT, pattern ARENA_SET_DARK+    -- ** Used in PlaceKind, but not in CaveKind.+  , pattern RECT_WINDOWS_VERTICAL_LIT, pattern RECT_WINDOWS_VERTICAL_DARK, pattern RECT_WINDOWS_HORIZONTAL_LIT, pattern RECT_WINDOWS_HORIZONTAL_DARK, pattern TREE_SHADE_WALKABLE_LIT, pattern TREE_SHADE_WALKABLE_DARK, pattern SMOKE_CLUMP_LIT, pattern SMOKE_CLUMP_DARK, pattern GLASSHOUSE_VERTICAL_LIT, pattern GLASSHOUSE_VERTICAL_DARK, pattern GLASSHOUSE_HORIZONTAL_LIT, pattern GLASSHOUSE_HORIZONTAL_DARK, pattern BUSH_CLUMP_LIT, pattern BUSH_CLUMP_DARK, pattern FOG_CLUMP_LIT, pattern FOG_CLUMP_DARK, pattern STAIR_TERMINAL_LIT, pattern STAIR_TERMINAL_DARK, pattern CACHE, pattern SIGNBOARD, pattern STAIRCASE_UP, pattern ORDINARY_STAIRCASE_UP, pattern STAIRCASE_OUTDOOR_UP, pattern GATED_STAIRCASE_UP, pattern STAIRCASE_DOWN, pattern ORDINARY_STAIRCASE_DOWN, pattern STAIRCASE_OUTDOOR_DOWN, pattern GATED_STAIRCASE_DOWN, pattern TILE_INDOOR_ESCAPE_UP, pattern TILE_INDOOR_ESCAPE_DOWN, pattern TILE_OUTDOOR_ESCAPE_DOWN, pattern FLOOR_ACTOR_ITEM_LIT, pattern FLOOR_ACTOR_ITEM_DARK+  , pattern S_PILLAR, pattern S_RUBBLE_PILE, pattern S_LAMP_POST, pattern S_TREE_LIT, pattern S_TREE_DARK, pattern S_WALL_LIT, pattern S_WALL_DARK, pattern S_WALL_HORIZONTAL_LIT, pattern S_WALL_HORIZONTAL_DARK, pattern S_PULPIT, pattern S_BUSH_LIT, pattern S_FOG_LIT, pattern S_SMOKE_LIT, pattern S_FLOOR_ACTOR_LIT, pattern S_FLOOR_ACTOR_DARK, pattern S_FLOOR_ASHES_LIT, pattern S_FLOOR_ASHES_DARK, pattern S_SHADED_GROUND, pattern S_SHALLOW_WATER_LIT, pattern S_SHALLOW_WATER_DARK+  , groupNamesSingleton, groupNames+    -- * Content+  , content+  ) where -import Control.Arrow (first)-import Data.Maybe-import Data.Text (Text)+import Prelude ()++import Game.LambdaHack.Core.Prelude+ import qualified Data.Text as T -import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.ContentDef-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Feature-import Game.LambdaHack.Common.Msg import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal -cdefs :: ContentDef TileKind-cdefs = ContentDef-  { getSymbol = tsymbol-  , getName = tname-  , getFreq = tfreq-  , validate = validateTileKind-  , content =-      [wall, hardRock, pillar, pillarCache, lampPost, burningBush, bush, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorArenaShade, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit]-      ++ map makeDark [wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsLit, escapeUpLit, escapeDownLit, floorCorridorLit]-      ++ map makeDarkColor [stairsUpLit, stairsDownLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit]-  }-wall,        hardRock, pillar, pillarCache, lampPost, burningBush, bush, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorArenaShade, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind+import Content.ItemKindEmbed -wall = TileKind+-- * Group name patterns++-- Warning, many of these are also sythesized, so typos can happen.++groupNamesSingleton :: [GroupName TileKind]+groupNamesSingleton =+       [S_PILLAR, S_RUBBLE_PILE, S_LAMP_POST, S_TREE_LIT, S_TREE_DARK, S_WALL_LIT, S_WALL_DARK, S_WALL_HORIZONTAL_LIT, S_WALL_HORIZONTAL_DARK, S_PULPIT, S_BUSH_LIT, S_FOG_LIT, S_SMOKE_LIT, S_FLOOR_ACTOR_LIT, S_FLOOR_ACTOR_DARK, S_FLOOR_ASHES_LIT, S_FLOOR_ASHES_DARK, S_SHADED_GROUND, S_SHALLOW_WATER_LIT, S_SHALLOW_WATER_DARK]+    ++ [S_SUSPECT_VERTICAL_WALL_LIT, S_SUSPECT_HORIZONTAL_WALL_LIT, S_CLOSED_VERTICAL_DOOR_LIT, S_CLOSED_HORIZONTAL_DOOR_LIT, S_OPEN_VERTICAL_DOOR_LIT, S_OPEN_HORIZONTAL_DOOR_LIT, S_SIGNBOARD_UNREAD]+    ++ [S_BUSH_DARK, S_CLOSED_HORIZONTAL_DOOR_DARK, S_CLOSED_VERTICAL_DOOR_DARK, S_OPEN_HORIZONTAL_DOOR_DARK, S_OPEN_VERTICAL_DOOR_DARK, S_SUSPECT_HORIZONTAL_WALL_DARK, S_SUSPECT_VERTICAL_WALL_DARK]++-- ** Used in PlaceKind, but not in CaveKind.+pattern S_PILLAR, S_RUBBLE_PILE, S_LAMP_POST, S_TREE_LIT, S_TREE_DARK, S_WALL_LIT, S_WALL_DARK, S_WALL_HORIZONTAL_LIT, S_WALL_HORIZONTAL_DARK, S_PULPIT, S_BUSH_LIT, S_FOG_LIT, S_SMOKE_LIT, S_FLOOR_ACTOR_LIT, S_FLOOR_ACTOR_DARK, S_FLOOR_ASHES_LIT, S_FLOOR_ASHES_DARK, S_SHADED_GROUND, S_SHALLOW_WATER_LIT, S_SHALLOW_WATER_DARK :: GroupName TileKind++-- ** Used only internally in other TileKind definitions or never used.+pattern S_SUSPECT_VERTICAL_WALL_LIT, S_SUSPECT_HORIZONTAL_WALL_LIT, S_CLOSED_VERTICAL_DOOR_LIT, S_CLOSED_HORIZONTAL_DOOR_LIT, S_OPEN_VERTICAL_DOOR_LIT, S_OPEN_HORIZONTAL_DOOR_LIT, S_SIGNBOARD_UNREAD :: GroupName TileKind++-- * Not used, but needed, because auto-generated. Singletons.+pattern S_BUSH_DARK, S_CLOSED_HORIZONTAL_DOOR_DARK, S_CLOSED_VERTICAL_DOOR_DARK, S_OPEN_HORIZONTAL_DOOR_DARK, S_OPEN_VERTICAL_DOOR_DARK, S_SUSPECT_HORIZONTAL_WALL_DARK, S_SUSPECT_VERTICAL_WALL_DARK :: GroupName TileKind++-- TODO: if we stick to the current system of generating extra kinds and their+-- group names, let's also add the generated group names to @groupNames@.+groupNames :: [GroupName TileKind]+groupNames =+       [FILLER_WALL, FLOOR_CORRIDOR_LIT, FLOOR_CORRIDOR_DARK, TRAIL_LIT, SAFE_TRAIL_LIT, LAB_TRAIL_LIT, DAMP_FLOOR_LIT, DAMP_FLOOR_DARK, OUTDOOR_OUTER_FENCE, DIRT_LIT, DIRT_DARK, FLOOR_ARENA_LIT, FLOOR_ARENA_DARK]+    ++ [EMPTY_SET_LIT, EMPTY_SET_DARK, NOISE_SET_LIT, POWER_SET_LIT, POWER_SET_DARK, BATTLE_SET_LIT, BATTLE_SET_DARK, BRAWL_SET_LIT, SHOOTOUT_SET_LIT, ZOO_SET_LIT, ZOO_SET_DARK, FLIGHT_SET_LIT, FLIGHT_SET_DARK, AMBUSH_SET_LIT, AMBUSH_SET_DARK, ARENA_SET_LIT, ARENA_SET_DARK]+    ++ [RECT_WINDOWS_VERTICAL_LIT, RECT_WINDOWS_VERTICAL_DARK, RECT_WINDOWS_HORIZONTAL_LIT, RECT_WINDOWS_HORIZONTAL_DARK, TREE_SHADE_WALKABLE_LIT, TREE_SHADE_WALKABLE_DARK, SMOKE_CLUMP_LIT, SMOKE_CLUMP_DARK, GLASSHOUSE_VERTICAL_LIT, GLASSHOUSE_VERTICAL_DARK, GLASSHOUSE_HORIZONTAL_LIT, GLASSHOUSE_HORIZONTAL_DARK, BUSH_CLUMP_LIT, BUSH_CLUMP_DARK, FOG_CLUMP_LIT, FOG_CLUMP_DARK, STAIR_TERMINAL_LIT, STAIR_TERMINAL_DARK, CACHE, SIGNBOARD, STAIRCASE_UP, ORDINARY_STAIRCASE_UP, STAIRCASE_OUTDOOR_UP, GATED_STAIRCASE_UP, STAIRCASE_DOWN, ORDINARY_STAIRCASE_DOWN, STAIRCASE_OUTDOOR_DOWN, GATED_STAIRCASE_DOWN, TILE_INDOOR_ESCAPE_UP, TILE_INDOOR_ESCAPE_DOWN, TILE_OUTDOOR_ESCAPE_DOWN, FLOOR_ACTOR_ITEM_LIT, FLOOR_ACTOR_ITEM_DARK]+    ++ [OBSCURED_VERTICAL_WALL_LIT, OBSCURED_HORIZONTAL_WALL_LIT, TRAPPED_VERTICAL_DOOR_LIT, TRAPPED_HORIZONAL_DOOR_LIT, TREE_BURNING_OR_NOT, BUSH_BURNING_OR_NOT, CACHE_OR_NOT]+    ++ [BRAWL_SET_DARK, NOISE_SET_DARK, OBSCURED_HORIZONTAL_WALL_DARK, OBSCURED_VERTICAL_WALL_DARK, SHOOTOUT_SET_DARK, TRAPPED_HORIZONAL_DOOR_DARK, TRAPPED_VERTICAL_DOOR_DARK]++pattern FILLER_WALL, FLOOR_CORRIDOR_LIT, FLOOR_CORRIDOR_DARK, TRAIL_LIT, SAFE_TRAIL_LIT, LAB_TRAIL_LIT, DAMP_FLOOR_LIT, DAMP_FLOOR_DARK, OUTDOOR_OUTER_FENCE, DIRT_LIT, DIRT_DARK, FLOOR_ARENA_LIT, FLOOR_ARENA_DARK :: GroupName TileKind++pattern EMPTY_SET_LIT, EMPTY_SET_DARK, NOISE_SET_LIT, POWER_SET_LIT, POWER_SET_DARK, BATTLE_SET_LIT, BATTLE_SET_DARK, BRAWL_SET_LIT, SHOOTOUT_SET_LIT, ZOO_SET_LIT, ZOO_SET_DARK, FLIGHT_SET_LIT, FLIGHT_SET_DARK, AMBUSH_SET_LIT, AMBUSH_SET_DARK, ARENA_SET_LIT, ARENA_SET_DARK :: GroupName TileKind++-- ** Used in PlaceKind, but not in CaveKind.+pattern RECT_WINDOWS_VERTICAL_LIT, RECT_WINDOWS_VERTICAL_DARK, RECT_WINDOWS_HORIZONTAL_LIT, RECT_WINDOWS_HORIZONTAL_DARK, TREE_SHADE_WALKABLE_LIT, TREE_SHADE_WALKABLE_DARK, SMOKE_CLUMP_LIT, SMOKE_CLUMP_DARK, GLASSHOUSE_VERTICAL_LIT, GLASSHOUSE_VERTICAL_DARK, GLASSHOUSE_HORIZONTAL_LIT, GLASSHOUSE_HORIZONTAL_DARK, BUSH_CLUMP_LIT, BUSH_CLUMP_DARK, FOG_CLUMP_LIT, FOG_CLUMP_DARK, STAIR_TERMINAL_LIT, STAIR_TERMINAL_DARK, CACHE, SIGNBOARD, STAIRCASE_UP, ORDINARY_STAIRCASE_UP, STAIRCASE_OUTDOOR_UP, GATED_STAIRCASE_UP, STAIRCASE_DOWN, ORDINARY_STAIRCASE_DOWN, STAIRCASE_OUTDOOR_DOWN, GATED_STAIRCASE_DOWN, TILE_INDOOR_ESCAPE_UP, TILE_INDOOR_ESCAPE_DOWN, TILE_OUTDOOR_ESCAPE_DOWN, FLOOR_ACTOR_ITEM_LIT, FLOOR_ACTOR_ITEM_DARK :: GroupName TileKind++-- ** Used only internally in other TileKind definitions or never used.+pattern OBSCURED_VERTICAL_WALL_LIT, OBSCURED_HORIZONTAL_WALL_LIT, TRAPPED_VERTICAL_DOOR_LIT, TRAPPED_HORIZONAL_DOOR_LIT, TREE_BURNING_OR_NOT, BUSH_BURNING_OR_NOT, CACHE_OR_NOT :: GroupName TileKind++-- * Not used, but needed, because auto-generated. Not singletons.+pattern BRAWL_SET_DARK, NOISE_SET_DARK, OBSCURED_HORIZONTAL_WALL_DARK, OBSCURED_VERTICAL_WALL_DARK, SHOOTOUT_SET_DARK, TRAPPED_HORIZONAL_DOOR_DARK, TRAPPED_VERTICAL_DOOR_DARK :: GroupName TileKind++-- ** Used in CaveKind and perhaps elsewhere (or a dark/lit version thereof).+pattern FILLER_WALL = GroupName "fillerWall"+pattern FLOOR_CORRIDOR_LIT = GroupName "floorCorridorLit"+pattern FLOOR_CORRIDOR_DARK = GroupName "floorCorridorDark"+pattern TRAIL_LIT = GroupName "trailLit"+pattern SAFE_TRAIL_LIT = GroupName "safeTrailLit"+pattern LAB_TRAIL_LIT = GroupName "labTrailLit"+  -- these three would work without @_LIT@, but it will be needed when+  -- in the future a lit trail is made from terrain that has an autogenerated+  -- dark variant+pattern DAMP_FLOOR_LIT = GroupName "damp floor Lit"+pattern DAMP_FLOOR_DARK = GroupName "damp floor Dark"+pattern OUTDOOR_OUTER_FENCE = GroupName "outdoor outer fence"+pattern DIRT_LIT = GroupName "dirt Lit"+pattern DIRT_DARK = GroupName "dirt Dark"+pattern FLOOR_ARENA_LIT = GroupName "floorArenaLit"+pattern FLOOR_ARENA_DARK = GroupName "floorArenaDark"++-- ** Used in CaveKind and perhaps elsewhere; sets of tiles for filling cave.+pattern EMPTY_SET_LIT = GroupName "emptySetLit"+pattern EMPTY_SET_DARK = GroupName "emptySetDark"+pattern NOISE_SET_LIT = GroupName "noiseSetLit"+pattern POWER_SET_LIT = GroupName "powerSetLit"+pattern POWER_SET_DARK = GroupName "powerSetDark"+pattern BATTLE_SET_LIT = GroupName "battleSetLit"+pattern BATTLE_SET_DARK = GroupName "battleSetDark"+pattern BRAWL_SET_LIT = GroupName "brawlSetLit"+pattern SHOOTOUT_SET_LIT = GroupName "shootoutSetLit"+pattern ZOO_SET_LIT = GroupName "zooSetLit"+pattern ZOO_SET_DARK = GroupName "zooSetDark"+pattern FLIGHT_SET_LIT = GroupName "flightSetLit"+pattern FLIGHT_SET_DARK = GroupName "flightSetDark"+pattern AMBUSH_SET_LIT = GroupName "ambushSetLit"+pattern AMBUSH_SET_DARK = GroupName "ambushSetDark"+pattern ARENA_SET_LIT = GroupName "arenaSetLit"+pattern ARENA_SET_DARK = GroupName "arenaSetDark"++-- ** Used in PlaceKind, but not in CaveKind. Not singletons.+pattern RECT_WINDOWS_VERTICAL_LIT = GroupName "rectWindowsVerticalLit"+pattern RECT_WINDOWS_VERTICAL_DARK = GroupName "rectWindowsVerticalDark"+pattern RECT_WINDOWS_HORIZONTAL_LIT = GroupName "rectWindowsHorizontalLit"+pattern RECT_WINDOWS_HORIZONTAL_DARK = GroupName "rectWindowsHorizontalDark"+pattern TREE_SHADE_WALKABLE_LIT = GroupName "treeShadeWalkableLit"+pattern TREE_SHADE_WALKABLE_DARK = GroupName "treeShadeWalkableDark"+pattern SMOKE_CLUMP_LIT = GroupName "smokeClumpLit"+pattern SMOKE_CLUMP_DARK = GroupName "smokeClumpDark"+pattern GLASSHOUSE_VERTICAL_LIT = GroupName "glasshouseVerticalLit"+pattern GLASSHOUSE_VERTICAL_DARK = GroupName "glasshouseVerticalDark"+pattern GLASSHOUSE_HORIZONTAL_LIT = GroupName "glasshouseHorizontalLit"+pattern GLASSHOUSE_HORIZONTAL_DARK = GroupName "glasshouseHorizontalDark"+pattern BUSH_CLUMP_LIT = GroupName "bushClumpLit"+pattern BUSH_CLUMP_DARK = GroupName "bushClumpDark"+pattern FOG_CLUMP_LIT = GroupName "fogClumpLit"+pattern FOG_CLUMP_DARK = GroupName "fogClumpDark"+pattern STAIR_TERMINAL_LIT = GroupName "stair terminal Lit"+pattern STAIR_TERMINAL_DARK = GroupName "stair terminal Dark"+pattern CACHE = GroupName "cache"+pattern SIGNBOARD = GroupName "signboard"+pattern STAIRCASE_UP = GroupName "staircase up"+pattern ORDINARY_STAIRCASE_UP = GroupName "ordinary staircase up"+pattern STAIRCASE_OUTDOOR_UP = GroupName "staircase outdoor up"+pattern GATED_STAIRCASE_UP = GroupName "gated staircase up"+pattern STAIRCASE_DOWN = GroupName "staircase down"+pattern ORDINARY_STAIRCASE_DOWN = GroupName "ordinary staircase down"+pattern STAIRCASE_OUTDOOR_DOWN = GroupName "staircase outdoor down"+pattern GATED_STAIRCASE_DOWN = GroupName "gated staircase down"+pattern TILE_INDOOR_ESCAPE_UP = GroupName "indoor escape up"+pattern TILE_INDOOR_ESCAPE_DOWN = GroupName "indoor escape down"+pattern TILE_OUTDOOR_ESCAPE_DOWN = GroupName "outdoor escape down"+pattern FLOOR_ACTOR_ITEM_LIT = GroupName "floorActorItemLit"+pattern FLOOR_ACTOR_ITEM_DARK = GroupName "floorActorItemDark"++-- ** Used in PlaceKind, but not in CaveKind. Singletons.+pattern S_PILLAR = GroupName "pillar"+pattern S_RUBBLE_PILE = GroupName "rubble pile"+pattern S_LAMP_POST = GroupName "lamp post"+pattern S_TREE_LIT = GroupName "tree Lit"+pattern S_TREE_DARK = GroupName "tree Dark"+pattern S_WALL_LIT = GroupName "wall Lit"+pattern S_WALL_DARK = GroupName "wall Dark"+pattern S_WALL_HORIZONTAL_LIT = GroupName "wall horizontal Lit"+pattern S_WALL_HORIZONTAL_DARK = GroupName "wall horizontal Dark"+pattern S_PULPIT = GroupName "pulpit"+pattern S_BUSH_LIT = GroupName "bush Lit"+pattern S_FOG_LIT = GroupName "fog Lit"+pattern S_SMOKE_LIT = GroupName "smoke Lit"+pattern S_FLOOR_ACTOR_LIT = GroupName "floor with actors Lit"+pattern S_FLOOR_ACTOR_DARK = GroupName "floor with actors Dark"+pattern S_FLOOR_ASHES_LIT = GroupName "floor with ashes Lit"+pattern S_FLOOR_ASHES_DARK = GroupName "floor with ashes Dark"+pattern S_SHADED_GROUND = GroupName "shaded ground"+pattern S_SHALLOW_WATER_LIT = GroupName "shallow water Lit"+pattern S_SHALLOW_WATER_DARK = GroupName "shallow water Dark"++-- ** Used only internally in other TileKind definitions. Not singletons.+pattern OBSCURED_VERTICAL_WALL_LIT = GroupName "obscured vertical wall Lit"+pattern OBSCURED_HORIZONTAL_WALL_LIT = GroupName "obscured horizontal wall Lit"+pattern TRAPPED_VERTICAL_DOOR_LIT = GroupName "trapped vertical door Lit"+pattern TRAPPED_HORIZONAL_DOOR_LIT = GroupName "trapped horizontal door Lit"+pattern TREE_BURNING_OR_NOT = GroupName "tree burning or not"+pattern BUSH_BURNING_OR_NOT = GroupName "bush burning or not"+pattern CACHE_OR_NOT = GroupName "cache or not"++-- ** Used only internally in other TileKind definitions. Singletons.+pattern S_SUSPECT_VERTICAL_WALL_LIT = GroupName "suspect vertical wall Lit"+pattern S_SUSPECT_HORIZONTAL_WALL_LIT = GroupName "suspect horizontal wall Lit"+pattern S_CLOSED_VERTICAL_DOOR_LIT = GroupName "closed vertical door Lit"+pattern S_CLOSED_HORIZONTAL_DOOR_LIT = GroupName "closed horizontal door Lit"+pattern S_OPEN_VERTICAL_DOOR_LIT = GroupName "open vertical door Lit"+pattern S_OPEN_HORIZONTAL_DOOR_LIT = GroupName "open horizontal door Lit"+pattern S_SIGNBOARD_UNREAD = GroupName "signboard unread"++-- * Not used, but needed, because auto-generated. Not singletons.+-- This is a rotten compromise, because these are synthesized below,+-- so typos can happen. Similarly below+pattern BRAWL_SET_DARK = GroupName "brawlSetDark"+pattern NOISE_SET_DARK = GroupName "noiseSetDark"+pattern OBSCURED_HORIZONTAL_WALL_DARK =+  GroupName "obscured horizontal wall Dark"+pattern OBSCURED_VERTICAL_WALL_DARK = GroupName "obscured vertical wall Dark"+pattern SHOOTOUT_SET_DARK = GroupName "shootoutSetDark"+pattern TRAPPED_HORIZONAL_DOOR_DARK = GroupName "trapped horizontal door Dark"+pattern TRAPPED_VERTICAL_DOOR_DARK = GroupName "trapped vertical door Dark"++-- * Not used, but needed, because auto-generated. Singletons.+pattern S_BUSH_DARK = GroupName "bush Dark"+pattern S_CLOSED_HORIZONTAL_DOOR_DARK = GroupName "closed horizontal door Dark"+pattern S_CLOSED_VERTICAL_DOOR_DARK = GroupName "closed vertical door Dark"+pattern S_OPEN_HORIZONTAL_DOOR_DARK = GroupName "open horizontal door Dark"+pattern S_OPEN_VERTICAL_DOOR_DARK = GroupName "open vertical door Dark"+pattern S_SUSPECT_HORIZONTAL_WALL_DARK =+  GroupName "suspect horizontal wall Dark"+pattern S_SUSPECT_VERTICAL_WALL_DARK = GroupName "suspect vertical wall Dark"++-- * Content++content :: [TileKind]+content =+  [unknown, unknownOuterFence, basicOuterFence, bedrock, wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, pillar, pillarCache, lampPost, signboardUnread, signboardRead, tree, treeBurnt, treeBurning, rubble, rubbleSpice, doorTrapped, doorClosed, doorTrappedH, doorClosedH, stairsUp, stairsTrappedUp, stairsOutdoorUp, stairsGatedUp, stairsDown, stairsTrappedDown, stairsOutdoorDown, stairsGatedDown, escapeUp, escapeDown, escapeOutdoorDown, wallGlass, wallGlassSpice, wallGlassH, wallGlassHSpice, pillarIce, pulpit, bush, bushBurnt, bushBurning, fog, fogDark, smoke, smokeDark, doorOpen, doorOpenH, floorCorridor, floorArena, floorDamp, floorDirt, floorDirtSpice, floorActor, floorActorItem, floorAshes, shallowWater, shallowWaterSpice, floorRed, floorBlue, floorGreen, floorBrown, floorArenaShade, outdoorFence ]+  ++ map makeDark ldarkable+  ++ map makeDarkColor ldarkColorable++unknown,    unknownOuterFence, basicOuterFence, bedrock, wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, pillar, pillarCache, lampPost, signboardUnread, signboardRead, tree, treeBurnt, treeBurning, rubble, rubbleSpice, doorTrapped, doorClosed, doorTrappedH, doorClosedH, stairsUp, stairsTrappedUp, stairsOutdoorUp, stairsGatedUp, stairsDown, stairsTrappedDown, stairsOutdoorDown, stairsGatedDown, escapeUp, escapeDown, escapeOutdoorDown, wallGlass, wallGlassSpice, wallGlassH, wallGlassHSpice, pillarIce, pulpit, bush, bushBurnt, bushBurning, fog, fogDark, smoke, smokeDark, doorOpen, doorOpenH, floorCorridor, floorArena, floorDamp, floorDirt, floorDirtSpice, floorActor, floorActorItem, floorAshes, shallowWater, shallowWaterSpice, floorRed, floorBlue, floorGreen, floorBrown, floorArenaShade, outdoorFence :: TileKind++ldarkable :: [TileKind]+ldarkable = [wall, wallSuspect, wallObscured, wallH, wallSuspectH, wallObscuredDefacedH, wallObscuredFrescoedH, doorTrapped, doorClosed, doorTrappedH, doorClosedH, wallGlass, wallGlassSpice, wallGlassH, wallGlassHSpice, doorOpen, doorOpenH, floorCorridor, shallowWater, shallowWaterSpice]++ldarkColorable :: [TileKind]+ldarkColorable = [tree, bush, floorArena, floorDamp, floorDirt, floorDirtSpice, floorActor, floorActorItem]++-- Symbols to be used (the Nethack visual tradition imposes inconsistency):+--         LOS    noLOS+-- Walk    .|-#~  :;+-- noWalk  %^-|   -| O&<>++--+-- can be opened ^&++-- can be closed |-+-- some noWalk can be changed without opening, regardless of symbol+-- not used yet:+-- : (curtain, etc., not flowing, but solid and static)+-- `' (not visible enough when immobile)++-- White, cyan and green terrain is usually inert, red is burning or trapped,+-- blue activable or trapped, magenta searchable or activable.++-- Note that for AI hints and UI comfort, most multiple-use @Embed@ tiles+-- should have a variant, which after first use transforms into a different+-- colour tile without @ChangeTo@ and similar (which then AI no longer touches).+-- If a tile is supposed to be repeatedly activated by AI (e.g., cache),+-- it should keep @ChangeTo@ for the whole time.++-- * Main tiles, in other games modified and some removed++-- ** Not walkable++-- *** Not clear++unknown = TileKind  -- needs to have index 0 and alter 1; no other with 1   { tsymbol  = ' '+  , tname    = "unknown space"+  , tfreq    = [(S_UNKNOWN_SPACE, 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = 1+  , tfeature = [Dark]+  }+unknownOuterFence = TileKind+  { tsymbol  = ' '+  , tname    = "unknown space"+  , tfreq    = [(S_UNKNOWN_OUTER_FENCE, 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = maxBound  -- impenetrable+  , tfeature = [Dark]+  }+basicOuterFence = TileKind+  { tsymbol  = ' '+  , tname    = "impenetrable bedrock"+  , tfreq    = [(S_BASIC_OUTER_FENCE, 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = maxBound  -- impenetrable+  , tfeature = [Dark]+  }+bedrock = TileKind+  { tsymbol  = ' '   , tname    = "bedrock"-  , tfreq    = [("fillerWall", 1), ("legendLit", 100), ("legendDark", 100)]-  , tcolor   = defBG-  , tcolor2  = defBG+  , tfreq    = [(FILLER_WALL, 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = 100   , tfeature = [Dark]       -- Bedrock being dark is bad for AI (forces it to backtrack to explore       -- bedrock at corridor turns) and induces human micromanagement       -- if there can be corridors joined diagonally (humans have to check-      -- with the cursor if the dark space is bedrock or unexplored).+      -- with the xhair if the dark space is bedrock or unexplored).       -- Lit bedrock would be even worse for humans, because it's harder       -- to guess which tiles are unknown and which can be explored bedrock.       -- The setup of Allure is ideal, with lit bedrock that is easily       -- distinguished from an unknown tile. However, LH follows the NetHack,       -- not the Angband, visual tradition, so we can't improve the situation,       -- unless we turn to subtle shades of black or non-ASCII glyphs,-      -- but that is yet different aesthetics and it's inconsistent-      -- with console frontends.+      -- but that is yet different aesthetics.   }-hardRock = TileKind-  { tsymbol  = ' '-  , tname    = "impenetrable bedrock"-  , tfreq    = [("basic outer fence", 1)]+wall = TileKind+  { tsymbol  = '|'+  , tname    = "granite wall"+  , tfreq    = [ (S_WALL_LIT, 100)+               , (RECT_WINDOWS_VERTICAL_LIT, 80) ]   , tcolor   = BrWhite-  , tcolor2  = BrWhite-  , tfeature = [Dark, Impenetrable]+  , tcolor2  = defFG+  , talter   = 100+  , tfeature = [BuildAs S_SUSPECT_VERTICAL_WALL_LIT]   }-pillar = TileKind-  { tsymbol  = 'O'-  , tname    = "rock"-  , tfreq    = [ ("cachable", 70)-               , ("legendLit", 100), ("legendDark", 100)-               , ("noiseSet", 100), ("skirmishSet", 5)-               , ("battleSet", 250) ]+wallSuspect = TileKind  -- only on client+  { tsymbol  = '|'+  , tname    = "suspect uneven wall"+  , tfreq    = [(S_SUSPECT_VERTICAL_WALL_LIT, 1)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = []+  , talter   = 2+  , tfeature = [ RevealAs TRAPPED_VERTICAL_DOOR_LIT+               , ObscureAs OBSCURED_VERTICAL_WALL_LIT+               ]   }-pillarCache = TileKind-  { tsymbol  = '&'-  , tname    = "cache"-  , tfreq    = [ ("cachable", 30)-               , ("legendLit", 100), ("legendDark", 100) ]+wallObscured = TileKind+  { tsymbol  = '|'+  , tname    = "scratched wall"+  , tfreq    = [(OBSCURED_VERTICAL_WALL_LIT, 1)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Cause $ Effect.CreateItem 1, ChangeTo "cachable"]+  , talter   = 5+  , tfeature = [ Embed SCRATCH_ON_WALL+               , HideAs S_SUSPECT_VERTICAL_WALL_LIT+               ]   }+wallH = TileKind+  { tsymbol  = '-'+  , tname    = "sandstone wall"+  , tfreq    = [ (S_WALL_HORIZONTAL_LIT, 100)+               , (RECT_WINDOWS_HORIZONTAL_LIT, 80) ]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 100+  , tfeature = [BuildAs S_SUSPECT_HORIZONTAL_WALL_LIT]+  }+wallSuspectH = TileKind  -- only on client+  { tsymbol  = '-'+  , tname    = "suspect painted wall"+  , tfreq    = [(S_SUSPECT_HORIZONTAL_WALL_LIT, 1)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 2+  , tfeature = [ RevealAs TRAPPED_HORIZONAL_DOOR_LIT+               , ObscureAs OBSCURED_HORIZONTAL_WALL_LIT+               ]+  }+wallObscuredDefacedH = TileKind+  { tsymbol  = '-'+  , tname    = "defaced wall"+  , tfreq    = [(OBSCURED_HORIZONTAL_WALL_LIT, 90)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 5+  , tfeature = [ Embed OBSCENE_PICTOGRAM+               , HideAs S_SUSPECT_HORIZONTAL_WALL_LIT+               ]+  }+wallObscuredFrescoedH = TileKind+  { tsymbol  = '-'+  , tname    = "frescoed wall"+  , tfreq    = [(OBSCURED_HORIZONTAL_WALL_LIT, 10)]+  , tcolor   = BrWhite+  , tcolor2  = defFG+  , talter   = 5+  , tfeature = [ Embed SUBTLE_FRESCO+               , HideAs S_SUSPECT_HORIZONTAL_WALL_LIT+               ]  -- a bit beneficial, but AI would loop if allowed to trigger+                  -- so no @ConsideredByAI@+  }+pillar = TileKind+  { tsymbol  = '0'+  , tname    = "rock outcrop"+  , tfreq    = [ (S_PILLAR, 1), (CACHE_OR_NOT, 70)+               , (STAIR_TERMINAL_LIT, 100), (STAIR_TERMINAL_DARK, 100)+               , (EMPTY_SET_LIT, 20), (NOISE_SET_LIT, 700)+               , (POWER_SET_DARK, 700)+               , (BATTLE_SET_DARK, 200), (BRAWL_SET_LIT, 50)+               , (SHOOTOUT_SET_LIT, 10), (ZOO_SET_DARK, 10) ]+  , tcolor   = BrCyan  -- not BrWhite, to tell from heroes+  , tcolor2  = Cyan+  , talter   = 100+  , tfeature = []+  }+pillarCache = TileKind+  { tsymbol  = '0'+  , tname    = "smoothed outcrop"+  , tfreq    = [(CACHE_OR_NOT, 30), (CACHE, 1), (STAIR_TERMINAL_DARK, 4)]+                 -- treasure only in dark staircases+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 5+  , tfeature = [ Embed TREASURE_CACHE, Embed TREASURE_CACHE_TRAP+               , ChangeTo CACHE_OR_NOT, ConsideredByAI ]+      -- Not explorable, but prominently placed, so hard to miss.+      -- Very beneficial, so AI eager to trigger, unless wary of traps.+  } lampPost = TileKind-  { tsymbol  = 'O'+  { tsymbol  = '0'   , tname    = "lamp post"-  , tfreq    = [("lampPostOver_O", 90)]+  , tfreq    = [(S_LAMP_POST, 1)]   , tcolor   = BrYellow   , tcolor2  = Brown+  , talter   = 100   , tfeature = []   }-burningBush = TileKind-  { tsymbol  = 'O'-  , tname    = "burning bush"-  , tfreq    = [("lampPostOver_O", 10), ("ambushSet", 3), ("battleSet", 2)]-  , tcolor   = BrRed-  , tcolor2  = Red-  , tfeature = []+signboardUnread = TileKind  -- client only, indicates never used by this faction+  { tsymbol  = '0'+  , tname    = "signboard"+  , tfreq    = [(S_SIGNBOARD_UNREAD, 1)]+  , tcolor   = BrCyan+  , tcolor2  = Cyan+  , talter   = 5+  , tfeature = [ ConsideredByAI  -- changes after use, so safe for AI+               , RevealAs SIGNBOARD  -- to display as hidden+               ]   }-bush = TileKind-  { tsymbol  = 'O'-  , tname    = "bush"-  , tfreq    = [("ambushSet", 100) ]-  , tcolor   = Green-  , tcolor2  = BrBlack-  , tfeature = [Dark]+signboardRead = TileKind+  { tsymbol  = '0'+  , tname    = "signboard"+  , tfreq    = [(SIGNBOARD, 1), (FLIGHT_SET_DARK, 1)]+  , tcolor   = BrCyan+  , tcolor2  = Cyan+  , talter   = 5+  , tfeature = [Embed SIGNAGE, HideAs S_SIGNBOARD_UNREAD]   } tree = TileKind-  { tsymbol  = 'O'+  { tsymbol  = '0'   , tname    = "tree"-  , tfreq    = [("skirmishSet", 14), ("battleSet", 20), ("treeShadeOver_O", 1)]+  , tfreq    = [ (BRAWL_SET_LIT, 140), (SHOOTOUT_SET_LIT, 10)+               , (FLIGHT_SET_LIT, 35), (AMBUSH_SET_LIT, 3)+               , (S_TREE_LIT, 1) ]   , tcolor   = BrGreen   , tcolor2  = Green+  , talter   = 50   , tfeature = []   }-wallV = TileKind-  { tsymbol  = '|'-  , tname    = "granite wall"-  , tfreq    = [("legendLit", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [HideAs "suspect vertical wall Lit"]+treeBurnt = tree+  { tname    = "burnt tree"+  , tfreq    = [ (AMBUSH_SET_DARK, 3), (ZOO_SET_DARK, 7), (BATTLE_SET_DARK, 50)+               , (TREE_BURNING_OR_NOT, 30) ]+  , tcolor   = BrBlack+  , tcolor2  = BrBlack+  , tfeature = Dark : tfeature tree   }-wallSuspectV = TileKind-  { tsymbol  = '|'-  , tname    = "moldy wall"-  , tfreq    = [("suspect vertical wall Lit", 1)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [Suspect, RevealAs "vertical closed door Lit"]+treeBurning = tree+  { tname    = "burning tree"+  , tfreq    = [ (AMBUSH_SET_DARK, 15), (ZOO_SET_DARK, 70)+               , (TREE_BURNING_OR_NOT, 70) ]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 5+  , tfeature = Embed BIG_FIRE : ChangeTo TREE_BURNING_OR_NOT : tfeature tree+      -- TODO: dousing off the tree will have more sense when it periodically+      -- explodes, hitting and lighting up the team and so betraying it   }-doorClosedV = TileKind+rubble = TileKind+  { tsymbol  = '&'+  , tname    = "rubble pile"+  , tfreq    = [ (S_RUBBLE_PILE, 1)+               , (STAIR_TERMINAL_LIT, 4), (STAIR_TERMINAL_DARK, 4)+               , (EMPTY_SET_LIT, 10), (EMPTY_SET_DARK, 10)+               , (NOISE_SET_LIT, 50), (POWER_SET_DARK, 50)+               , (ZOO_SET_DARK, 100), (AMBUSH_SET_DARK, 10) ]+  , tcolor   = BrYellow+  , tcolor2  = Brown+  , talter   = 4  -- boss can dig through+  , tfeature = [Embed RUBBLE, OpenTo S_FLOOR_ASHES_LIT]+      -- Getting the item is risky and, e.g., AI doesn't attempt it.+      -- Also, AI doesn't go out of its way to clear the way for heroes.+  }+rubbleSpice = rubble+  { tfreq    = [(SMOKE_CLUMP_LIT, 1), (SMOKE_CLUMP_DARK, 1)]+  , tfeature = Spice : tfeature rubble+  }+doorTrapped = TileKind   { tsymbol  = '+'-  , tname    = "closed door"-  , tfreq    = [("vertical closed door Lit", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ OpenTo "vertical open door Lit"-               , HideAs "suspect vertical wall Lit"+  , tname    = "trapped door"+  , tfreq    = [(TRAPPED_VERTICAL_DOOR_LIT, 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 2+  , tfeature = [ Embed DOORWAY_TRAP+               , OpenTo S_OPEN_VERTICAL_DOOR_LIT+               , HideAs S_SUSPECT_VERTICAL_WALL_LIT                ]   }-doorOpenV = TileKind-  { tsymbol  = '-'-  , tname    = "open door"-  , tfreq    = [("vertical open door Lit", 1)]+doorClosed = TileKind+  { tsymbol  = '+'+  , tname    = "closed door"+  , tfreq    = [(S_CLOSED_VERTICAL_DOOR_LIT, 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, NoItem, NoActor-               , CloseTo "vertical closed door Lit"-               ]-  }-wallH = TileKind-  { tsymbol  = '-'-  , tname    = "granite wall"-  , tfreq    = [("legendLit", 100)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [HideAs "suspect horizontal wall Lit"]+  , talter   = 2+  , tfeature = [OpenTo S_OPEN_VERTICAL_DOOR_LIT]  -- never hidden   }-wallSuspectH = TileKind-  { tsymbol  = '-'-  , tname    = "scratched wall"-  , tfreq    = [("suspect horizontal wall Lit", 1)]-  , tcolor   = BrWhite-  , tcolor2  = defFG-  , tfeature = [Suspect, RevealAs "horizontal closed door Lit"]+doorTrappedH = TileKind+  { tsymbol  = '+'+  , tname    = "trapped door"+  , tfreq    = [(TRAPPED_HORIZONAL_DOOR_LIT, 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 2+  , tfeature = [ Embed DOORWAY_TRAP+               , OpenTo S_OPEN_HORIZONTAL_DOOR_LIT+               , HideAs S_SUSPECT_HORIZONTAL_WALL_LIT+               ]   } doorClosedH = TileKind   { tsymbol  = '+'   , tname    = "closed door"-  , tfreq    = [("horizontal closed door Lit", 1)]-  , tcolor   = Brown-  , tcolor2  = BrBlack-  , tfeature = [ OpenTo "horizontal open door Lit"-               , HideAs "suspect horizontal wall Lit"-               ]-  }-doorOpenH = TileKind-  { tsymbol  = '|'-  , tname    = "open door"-  , tfreq    = [("horizontal open door Lit", 1)]+  , tfreq    = [(S_CLOSED_HORIZONTAL_DOOR_LIT, 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear, NoItem, NoActor-               , CloseTo "horizontal closed door Lit"-               ]+  , talter   = 2+  , tfeature = [OpenTo S_OPEN_HORIZONTAL_DOOR_LIT]  -- never hidden   }-stairsUpLit = TileKind+stairsUp = TileKind   { tsymbol  = '<'   , tname    = "staircase up"-  , tfreq    = [("legendLit", 100)]+  , tfreq    = [(STAIRCASE_UP, 9), (ORDINARY_STAIRCASE_UP, 1)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Ascend 1]+  , talter   = talterForStairs+  , tfeature = [Embed STAIRS_UP, ConsideredByAI]   }-stairsLit = TileKind-  { tsymbol  = '>'-  , tname    = "staircase"-  , tfreq    = [("legendLit", 100)]-  , tcolor   = BrCyan-  , tcolor2  = Cyan  -- TODO-  , tfeature = [ Walkable, Clear, NoItem, NoActor-               , Cause $ Effect.Ascend 1-               , Cause $ Effect.Ascend (-1) ]+stairsTrappedUp = TileKind+  { tsymbol  = '<'+  , tname    = "windy staircase up"+  , tfreq    = [(STAIRCASE_UP, 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = talterForStairs+  , tfeature = [ Embed STAIRS_UP, Embed STAIRS_TRAP_UP+               , ConsideredByAI, ChangeTo ORDINARY_STAIRCASE_UP ]+                 -- AI uses despite the trap; exploration more important   }-stairsDownLit = TileKind+stairsOutdoorUp = stairsUp+  { tname    = "signpost pointing backward"+  , tfreq    = [(STAIRCASE_OUTDOOR_UP, 1)]+  }+stairsGatedUp = stairsUp+  { tname    = "gated staircase up"+  , tfreq    = [(GATED_STAIRCASE_UP, 1)]+  , talter   = talterForStairs + 2  -- animals and bosses can't use+  }+stairsDown = TileKind   { tsymbol  = '>'   , tname    = "staircase down"-  , tfreq    = [("legendLit", 100)]+  , tfreq    = [(STAIRCASE_DOWN, 9), (ORDINARY_STAIRCASE_DOWN, 1)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Ascend (-1)]+  , talter   = talterForStairs+  , tfeature = [Embed STAIRS_DOWN, ConsideredByAI]   }-escapeUpLit = TileKind+stairsTrappedDown = TileKind+  { tsymbol  = '>'+  , tname    = "crooked staircase down"+  , tfreq    = [(STAIRCASE_DOWN, 1)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = talterForStairs+  , tfeature = [ Embed STAIRS_DOWN, Embed STAIRS_TRAP_DOWN+               , ConsideredByAI, ChangeTo ORDINARY_STAIRCASE_DOWN ]+  }+stairsOutdoorDown = stairsDown+  { tname    = "signpost pointing forward"+  , tfreq    = [(STAIRCASE_OUTDOOR_DOWN, 1)]+  }+stairsGatedDown = stairsDown+  { tname    = "gated staircase down"+  , tfreq    = [(GATED_STAIRCASE_DOWN, 1)]+  , talter   = talterForStairs + 2  -- animals and bosses can't use+  }+escapeUp = TileKind   { tsymbol  = '<'-  , tname    = "exit trapdoor up"-  , tfreq    = [("legendLit", 100)]+  , tname    = "escape hatch up"+  , tfreq    = [(TILE_INDOOR_ESCAPE_UP, 1)]   , tcolor   = BrYellow   , tcolor2  = BrYellow-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Escape 1]+  , talter   = 0  -- anybody can escape (or guard escape)+  , tfeature = [Embed ESCAPE, ConsideredByAI]   }-escapeDownLit = TileKind+escapeDown = TileKind   { tsymbol  = '>'-  , tname    = "exit trapdoor down"-  , tfreq    = [("legendLit", 100)]+  , tname    = "escape trapdoor down"+  , tfreq    = [(TILE_INDOOR_ESCAPE_DOWN, 1)]   , tcolor   = BrYellow   , tcolor2  = BrYellow-  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Escape (-1)]+  , talter   = 0  -- anybody can escape (or guard escape)+  , tfeature = [Embed ESCAPE, ConsideredByAI]   }-unknown = TileKind-  { tsymbol  = ' '-  , tname    = "unknown space"-  , tfreq    = [("unknown space", 1)]-  , tcolor   = defFG-  , tcolor2  = defFG-  , tfeature = [Dark]+escapeOutdoorDown = escapeDown+  { tname    = "escape back to town"+  , tfreq    = [(TILE_OUTDOOR_ESCAPE_DOWN, 1)]   }-floorCorridorLit = TileKind++-- *** Clear++wallGlass = TileKind+  { tsymbol  = '|'+  , tname    = "polished crystal wall"+  , tfreq    = [(GLASSHOUSE_VERTICAL_LIT, 1)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 10+  , tfeature = [BuildAs S_CLOSED_VERTICAL_DOOR_LIT, Clear]+  }+wallGlassSpice = wallGlass+  { tfreq    = [(RECT_WINDOWS_VERTICAL_LIT, 20)]+  , tfeature = Spice : tfeature wallGlass+  }+wallGlassH = TileKind+  { tsymbol  = '-'+  , tname    = "polished crystal wall"+  , tfreq    = [(GLASSHOUSE_HORIZONTAL_LIT, 1)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 10+  , tfeature = [BuildAs S_CLOSED_HORIZONTAL_DOOR_LIT, Clear]+  }+wallGlassHSpice = wallGlassH+  { tfreq    = [(RECT_WINDOWS_HORIZONTAL_LIT, 20)]+  , tfeature = Spice : tfeature wallGlassH+  }+pillarIce = TileKind+  { tsymbol  = '^'+  , tname    = "icy outcrop"+  , tfreq    = [(POWER_SET_DARK, 300)]+  , tcolor   = BrBlue+  , tcolor2  = Blue+  , talter   = 4  -- boss can dig through+  , tfeature = [Clear, Embed FROST, OpenTo S_SHALLOW_WATER_LIT]+  }+pulpit = TileKind+  { tsymbol  = '%'+  , tname    = "pulpit"+  , tfreq    = [(S_PULPIT, 1)]+  , tcolor   = BrYellow+  , tcolor2  = Brown+  , talter   = 5+  , tfeature = [Clear, Embed LECTERN]+                 -- mixed blessing, so AI ignores, saved for player fun+  }+bush = TileKind+  { tsymbol  = '%'+  , tname    = "bush"+  , tfreq    = [ (S_BUSH_LIT, 1), (SHOOTOUT_SET_LIT, 30), (FLIGHT_SET_LIT, 40)+               , (AMBUSH_SET_LIT, 3), (BUSH_CLUMP_LIT, 1) ]+  , tcolor   = BrGreen+  , tcolor2  = Green+  , talter   = 10+  , tfeature = [Clear]+  }+bushBurnt = bush+  { tname    = "burnt bush"+  , tfreq    = [ (BATTLE_SET_DARK, 30), (ZOO_SET_DARK, 30), (AMBUSH_SET_DARK, 3)+               , (BUSH_BURNING_OR_NOT, 70) ]+  , tcolor   = BrBlack+  , tcolor2  = BrBlack+  , tfeature = Dark : tfeature bush+  }+bushBurning = bush+  { tname    = "burning bush"+  , tfreq    = [ (AMBUSH_SET_DARK, 15), (ZOO_SET_DARK, 300)+               , (BUSH_BURNING_OR_NOT, 30) ]+  , tcolor   = BrRed+  , tcolor2  = Red+  , talter   = 5+  , tfeature = Embed SMALL_FIRE : ChangeTo BUSH_BURNING_OR_NOT+               : tfeature bush+  }++-- ** Walkable++-- *** Not clear++fog = TileKind+  { tsymbol  = ';'+  , tname    = "faint fog"+  , tfreq    = [ (S_FOG_LIT, 1), (EMPTY_SET_LIT, 50), (NOISE_SET_LIT, 100)+               , (SHOOTOUT_SET_LIT, 20)+               , (FOG_CLUMP_LIT, 60), (FOG_CLUMP_DARK, 60) ]+      -- lit fog is OK for shootout, because LOS is mutual, as opposed+      -- to dark fog, and so camper has little advantage, especially+      -- on big maps, where he doesn't know on which side of fog patch to hide+  , tcolor   = BrCyan+  , tcolor2  = Cyan+  , talter   = 0+  , tfeature = [Walkable, NoItem, OftenActor]+  }+fogDark = fog+  { tname    = "thick fog"+  , tfreq    = [ (EMPTY_SET_DARK, 50), (POWER_SET_DARK, 100)+               , (FLIGHT_SET_DARK, 50) ]+  , tfeature = Dark : tfeature fog+  }+smoke = TileKind+  { tsymbol  = ';'+  , tname    = "billowing smoke"+  , tfreq    = [ (S_SMOKE_LIT, 1), (LAB_TRAIL_LIT, 1), (STAIR_TERMINAL_LIT, 4)+               , (SMOKE_CLUMP_LIT, 3), (SMOKE_CLUMP_DARK, 3) ]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , talter   = 0+  , tfeature = [Walkable, NoItem]  -- not dark, embers+  }+smokeDark = smoke+  { tname    = "lingering smoke"+  , tfreq    = [ (STAIR_TERMINAL_DARK, 4), (AMBUSH_SET_DARK, 40)+               , (ZOO_SET_DARK, 20), (BATTLE_SET_DARK, 5) ]+  , tfeature = Dark : tfeature smoke+  }++-- *** Clear++doorOpen = TileKind+  { tsymbol  = '-'+  , tname    = "open door"+  , tfreq    = [(S_OPEN_VERTICAL_DOOR_LIT, 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , talter   = 4+  , tfeature = [ Walkable, Clear, NoItem, NoActor+               , CloseTo S_CLOSED_VERTICAL_DOOR_LIT+                   -- not explorable due to that+               ]+  }+doorOpenH = TileKind+  { tsymbol  = '|'+  , tname    = "open door"+  , tfreq    = [(S_OPEN_HORIZONTAL_DOOR_LIT, 1)]+  , tcolor   = Brown+  , tcolor2  = BrBlack+  , talter   = 4+  , tfeature = [ Walkable, Clear, NoItem, NoActor+               , CloseTo S_CLOSED_HORIZONTAL_DOOR_LIT+                   -- not explorable due to that+               ]+  }+floorCorridor = TileKind   { tsymbol  = '#'   , tname    = "corridor"-  , tfreq    = [("floorCorridorLit", 1)]+  , tfreq    = [(FLOOR_CORRIDOR_LIT, 1)]   , tcolor   = BrWhite   , tcolor2  = defFG+  , talter   = 0   , tfeature = [Walkable, Clear]   }-floorArenaLit = floorCorridorLit-  { tsymbol  = '.'+floorArena = floorCorridor+  { tsymbol  = floorSymbol   , tname    = "stone floor"-  , tfreq    = [ ("floorArenaLit", 1)-               , ("arenaSet", 1), ("emptySet", 1), ("noiseSet", 50)-               , ("battleSet", 1000), ("skirmishSet", 100)-               , ("ambushSet", 1000) ]+  , tfreq    = [ (FLOOR_ARENA_LIT, 1), (ARENA_SET_LIT, 1), (EMPTY_SET_LIT, 900)+               , (ZOO_SET_LIT, 600) ]   }-floorActorLit = floorArenaLit-  { tfreq    = []-  , tfeature = OftenActor : tfeature floorArenaLit+floorDamp = floorArena+  { tname    = "damp stone floor"+  , tfreq    = [ (NOISE_SET_LIT, 600), (POWER_SET_LIT, 600)+               , (DAMP_FLOOR_LIT, 1), (STAIR_TERMINAL_LIT, 20) ]   }-floorItemLit = floorArenaLit-  { tfreq    = []-  , tfeature = OftenItem : tfeature floorArenaLit+floorDirt = floorArena+  { tname    = "dirt floor"+  , tfreq    = [ (SHOOTOUT_SET_LIT, 1000), (FLIGHT_SET_LIT, 1000)+               , (AMBUSH_SET_LIT, 1000), (BATTLE_SET_LIT, 1000)+               , (BRAWL_SET_LIT, 1000), (DIRT_LIT, 1) ]   }-floorActorItemLit = floorItemLit-  { tfreq    = [("legendLit", 100)]  -- no OftenItem in legendDark-  , tfeature = OftenActor : tfeature floorItemLit+floorDirtSpice = floorDirt+  { tfreq    = [(TREE_SHADE_WALKABLE_LIT, 1), (BUSH_CLUMP_LIT, 1)]+  , tfeature = Spice : tfeature floorDirt   }-floorArenaShade = floorActorLit-  { tname    = "stone floor"  -- TODO: "shaded ground"-  , tfreq    = [("treeShadeOver_s", 1)]-  , tcolor2  = BrBlack-  , tfeature = Dark : tfeature floorActorLit  -- no OftenItem+floorActor = floorArena+  { tfreq    = [(S_FLOOR_ACTOR_LIT, 1)]+  , tfeature = OftenActor : tfeature floorArena   }-floorRedLit = floorArenaLit-  { tname    = "brick pavement"-  , tfreq    = [("trailLit", 30)]+floorActorItem = floorActor+  { tfreq    = [(FLOOR_ACTOR_ITEM_LIT, 1)]+  , tfeature = VeryOftenItem : tfeature floorActor+  }+floorAshes = floorActor+  { tfreq    = [ (SMOKE_CLUMP_LIT, 2), (SMOKE_CLUMP_DARK, 2)+               , (S_FLOOR_ASHES_LIT, 1), (S_FLOOR_ASHES_DARK, 1) ]+  , tname    = "dirt and ash pile"+  , tcolor   = Brown+  , tcolor2  = Brown+  }+shallowWater = TileKind+  { tsymbol  = '~'+  , tname    = "water puddle"+  , tfreq    = [ (S_SHALLOW_WATER_LIT, 1)+               , (EMPTY_SET_LIT, 5), (NOISE_SET_LIT, 20)+               , (POWER_SET_LIT, 20), (SHOOTOUT_SET_LIT, 5) ]+  , tcolor   = BrCyan+  , tcolor2  = Cyan+  , talter   = 0+  , tfeature = Embed SHALLOW_WATER : tfeature floorActor+  }+shallowWaterSpice = shallowWater+  { tfreq    = [(FOG_CLUMP_LIT, 40)]+  , tfeature = Spice : tfeature shallowWater+  }+floorRed = floorCorridor+  { tsymbol  = floorSymbol+  , tname    = "brick pavement"+  , tfreq    = [(TRAIL_LIT, 70), (SAFE_TRAIL_LIT, 70)]   , tcolor   = BrRed   , tcolor2  = Red-  , tfeature = Trail : tfeature floorArenaLit+  , tfeature = [Embed STRAIGHT_PATH, Trail, Walkable, Clear]   }-floorBlueLit = floorRedLit-  { tname    = "granite cobblestones"-  , tfreq    = [("trailLit", 100)]+floorBlue = floorRed+  { tname    = "frozen trail"+  , tfreq    = [(TRAIL_LIT, 100)]   , tcolor   = BrBlue   , tcolor2  = Blue+  , tfeature = [Embed FROZEN_GROUND, Trail, Walkable, Clear]   }-floorGreenLit = floorRedLit+floorGreen = floorRed   { tname    = "mossy stone path"-  , tfreq    = [("trailLit", 100)]+  , tfreq    = [(TRAIL_LIT, 70), (SAFE_TRAIL_LIT, 70)]   , tcolor   = BrGreen   , tcolor2  = Green   }-floorBrownLit = floorRedLit+floorBrown = floorRed   { tname    = "rotting mahogany deck"-  , tfreq    = [("trailLit", 10)]+  , tfreq    = [(TRAIL_LIT, 50), (SAFE_TRAIL_LIT, 50)]   , tcolor   = BrMagenta   , tcolor2  = Magenta   }+floorArenaShade = floorActor+  { tname    = "shaded ground"+  , tfreq    = [(S_SHADED_GROUND, 1), (TREE_SHADE_WALKABLE_LIT, 2)]+  , tcolor2  = BrBlack+  , tfeature = Dark : NoItem : tfeature floorActor+  } +outdoorFence = TileKind+  { tsymbol  = ' '+  , tname    = "event horizon"+  , tfreq    = [(OUTDOOR_OUTER_FENCE, 1)]+  , tcolor   = defFG+  , tcolor2  = defFG+  , talter   = maxBound  -- impenetrable+  , tfeature = [Dark]+  }++-- * Helper functions+ makeDark :: TileKind -> TileKind-makeDark k = let darkText :: Text -> Text-                 darkText t = maybe t (<> "Dark") $ T.stripSuffix "Lit" t-                 darkFrequency = map (first darkText) $ tfreq k-                 darkFeat (OpenTo t) = Just $ OpenTo $ darkText t-                 darkFeat (CloseTo t) = Just $ CloseTo $ darkText t-                 darkFeat (ChangeTo t) = Just $ ChangeTo $ darkText t-                 darkFeat (HideAs t) = Just $ HideAs $ darkText t-                 darkFeat (RevealAs t) = Just $ RevealAs $ darkText t-                 darkFeat OftenItem = Nothing-                 darkFeat feat = Just $ feat+makeDark k = let darkenText :: GroupName TileKind -> GroupName TileKind+                 darkenText t = maybe t (GroupName . (<> "Dark"))+                              $ T.stripSuffix "Lit" $ fromGroupName t+                 darkFrequency :: Freqs TileKind+                 darkFrequency = map (first darkenText) $ tfreq k+                 darkFeat (OpenTo t) = Just $ OpenTo $ darkenText t+                 darkFeat (CloseTo t) = Just $ CloseTo $ darkenText t+                 darkFeat (ChangeTo t) = Just $ ChangeTo $ darkenText t+                 darkFeat (OpenWith proj grps t) =+                   Just $ OpenWith proj grps $ darkenText t+                 darkFeat (CloseWith proj grps t) =+                   Just $ CloseWith proj grps $ darkenText t+                 darkFeat (ChangeWith proj grps t) =+                   Just $ ChangeWith proj grps $ darkenText t+                 darkFeat (HideAs t) = Just $ HideAs $ darkenText t+                 darkFeat (BuildAs t) = Just $ BuildAs $ darkenText t+                 darkFeat (RevealAs t) = Just $ RevealAs $ darkenText t+                 darkFeat (ObscureAs t) = Just $ ObscureAs $ darkenText t+                 darkFeat VeryOftenItem = Just OftenItem+                 darkFeat OftenItem = Nothing  -- items not common in the dark+                 darkFeat feat = Just feat              in k { tfreq    = darkFrequency                   , tfeature = Dark : mapMaybe darkFeat (tfeature k)                   }
+ GameDefinition/InGameHelp.txt view
@@ -0,0 +1,179 @@+This is a snapshot of in-game help, rendered with the default config file.+For more general gameplay information see+https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/PLAYING.md+++ Minimal cheat sheet for casual play++ Walk throughout a level with mouse or numeric keypad (right diagram below)+ or the Vi editor keys (middle) or the left-hand movement keys (left). Run until+ disturbed with Shift or Control. Go-to a position with LMB (left mouse button).+ In aiming mode, the same keys (and mouse) move the aiming crosshair.++      q w e     y k u     7 8 9+       \|/       \|/       \|/+      a-s-d     h-.-l     4-5-6+       /|\       /|\       /|\+      z x c     b j n     1 2 3++ Press `KP_5` (`5` on keypad) to wait, bracing for impact, which reduces any+ damage taken and prevents displacement by foes. Press `S-KP_5` or `C-KP_5`+ (the same key with Shift or Control) to lurk 0.1 of a turn, without bracing.++ Displace enemies by running into them with Shift/Control or S-LMB. Search,+ open, descend and melee by bumping into walls, doors, stairs and enemies.+ The best, and not on cooldown, melee weapon is automatically chosen+ for attack from your equipment and from among your body parts.++ The following few commands, joined with the movement and running keys,+ let you accomplish almost anything in the game, though not necessarily+ with the fewest keystrokes. You can also play the game exclusively+ with a mouse, or both mouse and keyboard (e.g., mouse for go-to+ and terrain inspection and keyboard for everything else). Lastly,+ you can select a command with arrows or mouse directly from the help+ screen or the dashboard and execute it on the spot.++  keys         command+  I            manage the shared inventory stash+  g or ,       grab item(s)+  ESC          clear messages/open main menu/finish aiming+  RET or INS   open dashboard/accept target+  SPACE        clear messages/show history/cycle detail level+  TAB          cycle among all party members+  *            cycle crosshair among enemies+  /            cycle crosshair among items+  M            modify any admissible terrain+  %            yell or yawn and stop sleeping+++ Optional mouse commands++ Screen area and UI mode (exploration/aiming) determine mouse click+ effects. Here we give an overview of effects of each button over+ the game map area. The list includes not only left and right buttons,+ but also the optional middle mouse button (MMB) and the mouse wheel,+ which is also used over menus to move selection. For mice without RMB,+ one can use Control key with LMB and for mice without MMB, one can use+ C-RMB or C-S-LMB.++  keys         command (exploration/aiming)+  LMB          go to pointer for 25 steps/fling at enemy+  S-LMB        run to pointer collectively for 25 steps/fling at enemy+  RMB or C-LMB start aiming at enemy under pointer/cycle detail level+  S-RMB        modify terrain at pointer+  MMB or C-RMB snap crosshair to floor under pointer/cycle detail level+  WHEEL-UP     swerve the aiming line+  WHEEL-DN     unswerve the aiming line++ Note that mouse is optional. Keyboard suffices, occasionally requiring+ a lookup for an obscure command key in help screens.+++ Mouse button effects per screen area, in exploration and in aiming modes++  Exploration    LMB (left mouse button)         RMB (right mouse button)+  message line   show history                    display help+  pointman tile  grab item(s)                    remove item(s)+  party on map   pick new pointman on screen     select party member on screen+  the map area   go to pointer for 25 steps      set crosshair to enemy+  level number   move aiming one level up        move aiming one level down+  level caption  open dashboard                  clear msgs and open main menu+  percent seen   explore nearest unknown spot    autoexplore 25 times+  crosshair info cycle crosshair among enemies   cycle crosshair among items+  party roster   pick new pointman on screen     select party member on screen+  Calm value     yell or yawn and stop sleeping  yell or yawn and stop sleeping+  HP gauge       rest (wait 25 times)            heed (lurk 0.1 turns 100 times)+  HP value       wait a turn, bracing for impact lurk 0.1 of a turn+  pointman info  auto-fling and keep choice      clear chosen item and crosshair++  Aiming Mode    LMB (left mouse button)         RMB (right mouse button)+  the map area   fling at enemy under pointer    snap crosshair to enemy+  level caption  accept target                   cancel aiming+  percent seen   aim at nearest upstairs         aim at nearest downstairs+++ All item-related commands++  keys         command+  I            manage the shared inventory stash+  O            manage the equipment outfit of the pointman+  g or ,       grab item(s)+  r            remove item(s)+  f            fling in-range projectile+  C-f          auto-fling and keep choice+  t            trigger consumable item+  C-t          trigger item and keep choice+  i            stash item into shared inventory+  o            equip item into outfit of the pointman+  G            manage items on the ground+  T            manage our total team belongings++ Note how lower case item commands (stash item, equip item) place items+ into a particular item store, while upper case item commands (manage Inventory,+ manage Outfit) open management menu for a store. Once a store menu is opened,+ you can switch stores with `<` and `>`, so the multiple commands only determine+ the starting item store. Each store is accessible from the dashboard as well.+++ Terrain exploration and modification commands++  keys         command+  TAB          cycle among all party members+  S-TAB        cycle backwards among all party members+  C-TAB        cycle among party members on the level+  C-S-TAB      cycle backwards among party members on the level+  m            modify door by closing it+  M            modify any admissible terrain+  =            select (or deselect) party member+  _            deselect (or select) all on the level+  ;            go to crosshair for 25 steps+  :            run to crosshair collectively for 25 steps+  [            explore nearest unknown spot+  ]            autoexplore 25 times+  R            rest (wait 25 times)+  C-R          heed (lurk 0.1 turns 100 times)+  0, 1 ... 9   pick a particular actor as the new pointman+++ All aiming commands++  keys         command+  ESC          clear messages/open main menu/finish aiming+  RET or INS   open dashboard/accept target+  SPACE        clear messages/show history/cycle detail level+  *            cycle crosshair among enemies+  /            cycle crosshair among items+  +            swerve the aiming line+  -            unswerve the aiming line+  \            cycle aiming modes+  C-?          set crosshair to nearest unknown spot+  C-/          set crosshair to nearest item+  C-{          aim at nearest upstairs+  C-}          aim at nearest downstairs+  <            move aiming one level up+  >            move aiming one level down+  BACKSPACE    clear chosen item and crosshair+++ Assorted commands++  keys         command+  %            yell or yawn and stop sleeping+  @            describe organs of the pointman+  #            show skill summary of the pointman+  ~            display relevant lore+  C-g          start new game+  C-x          save and exit to desktop+  C-q          quit game and start autoplay+  C-c          exit to desktop without saving+  ?            display help+  F1           display help immediately+  F12          show history+  v            voice last action again+  V            voice recorded macro again+  '            start recording commands+  C-S          save game backup+  C-P          print screen+++ For more playing instructions see file PLAYING.md.
GameDefinition/Main.hs view
@@ -1,13 +1,69 @@ -- | The main source code file of LambdaHack the game.-module Main ( main ) where+-- Module "TieKnot" is separated to make it usable in tests.+module Main+  ( main+  ) where -import System.Environment (getArgs)+import Prelude () +import Game.LambdaHack.Core.Prelude++import           Control.Concurrent.Async+import qualified Control.Exception as Ex+import qualified GHC.IO.Encoding as SIO+import qualified Options.Applicative as OA+import qualified System.IO as SIO++#ifndef USE_JSFILE+import qualified GHC.IO.Handle+import           System.FilePath++import Game.LambdaHack.Common.File (tryCreateDir)+import Game.LambdaHack.Common.Misc+#endif++import Game.LambdaHack.Server (serverOptionsPI)+ import TieKnot --- | Tie the LambdaHack engine client, server and frontend code--- with the game-specific content definitions, and run the game.+-- | Parse commandline options, tie the engine, content and clients knot,+-- run the game and handle exit. main :: IO () main = do-  args <- getArgs-  tieKnot args+  -- Correct unset or some other too primitive encodings.+  let enc = SIO.localeEncoding+  when (show enc `elem` ["ASCII", "ISO-8859-1", "ISO-8859-2"]) $+    SIO.setLocaleEncoding SIO.utf8+  -- This test is faulty with JS, because it reports the browser console+  -- is not a terminal, but then we can't open files to contain the logs.+  -- Also it bloats the outcome JS file, so disabled.+#ifndef USE_JSFILE+  -- Special case hack, when the game is started not on a console.+  -- Without this, any attempt to output on stdout crashes a Windows exe+  -- (at least on Windows Vista) launched from the desktop or start menu.+  -- This is very crude and results in the inability to, e.g., process+  -- the output of @--help@ through a unix pipe. However, this should be+  -- effective on all Windows version, without the need to test all.+  isTerminal <- SIO.hIsTerminalDevice SIO.stdout+  unless isTerminal $ do+    dataDir <- appDataDir+    tryCreateDir dataDir+    fstdout <- SIO.openFile (dataDir </> "stdout.txt") SIO.WriteMode+    fstderr <- SIO.openFile (dataDir </> "stderr.txt") SIO.WriteMode+    GHC.IO.Handle.hDuplicateTo fstdout SIO.stdout+    GHC.IO.Handle.hDuplicateTo fstderr SIO.stderr+#else+  -- Work around display of one character per line.+  SIO.hSetBuffering SIO.stderr SIO.LineBuffering+#endif+  -- Fail here, not inside server code, so that savefiles are not removed,+  -- because they are not the source of the failure.+  !serverOptions <- OA.execParser serverOptionsPI+  resOrEx :: Either Ex.SomeException () <- Ex.try $ tieKnot serverOptions+  let unwrapEx e = case Ex.fromException e of+        Just (ExceptionInLinkedThread _ ex) -> unwrapEx ex+        _ -> e+  case resOrEx of+    Right () -> return ()+    Left ex -> Ex.throwIO $ unwrapEx ex+                 -- we are in the main thread, so now really exit
− GameDefinition/MainMenu.ascii 
@@ -1,26 +0,0 @@------------------------------------------------------------------------------------|                                                                                |-|                      >> LambdaHack <<                                          |-|                                                                                |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                      {{{{{{{{{{{{{{{{{{{{{{{{{                                 |-|                                                                                |-|                                                                                |-|                        Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) |-----------------------------------------------------------------------------------
GameDefinition/PLAYING.md view
@@ -1,260 +1,619 @@ Playing LambdaHack ================== -LambdaHack is a small dungeon crawler illustrating the roguelike game engine-of the same name. Playing the game involves exploring spooky dungeons,-alone or in a party of fearless adventurers, setting up ambushes-for unwary creatures, hiding in shadows, bumping into unspeakable horrors,-hidden passages and gorgeous magical treasure and making creative use-of it all. The madness-inspiring abominations that multiply in the depths-perform the same feats, due to their aberrant, abstract hyper-intelligence,-while tirelessly chasing the elusive heroes by sight, sound and smell.+The following backstory blurb is a copy of the sample game intro screen: + LambdaHack is a small dungeon crawler+ illustrating the roguelike game engine+ of the same name. Playing the game+ involves exploring spooky dungeons,+ alone or in a party of fearless+ explorers, avoiding and setting up+ ambushes, hiding in shadows from+ the gaze of unspeakable horrors,+ discovering secret passages and+ gorgeous magical treasure and making+ creative use of it all.++ The madness-inspiring abominations that+ multiply in the depths perform the same+ feats, due to their aberrant, abstract+ hyper-intelligence. They look out for+ any sign of weakness or indecision,+ ready to tirelessly chase the elusive+ heroes by sight, sound and smell.+++What to expect+--------------++LambdaHack is a turn-based game. You issue a command.+Then you watch its results unfold on the screen, without you being able+to intervene. Then the dust settles and you have as much time+as you want to inspect the battlefield and think about your next move.+ Once the few basic command keys and on-screen symbols are learned, mastery and enjoyment of the game is the matter of tactical skill and literary imagination. To be honest, a lot of imagination is required-for this rudimentary game, but it's playable and winnable.-Contributions are welcome.+for this modest sample game, but it has its own distinct quirky mood+and is playable and winnable. +The game differs from classic roguelikes in a few ways: -Heroes-------+* player manually controls each member of his squad, though often the best+  tactics is to scout with only one character (a classic roguelike feel)+  and let others guard important areas+* the game is turn-based, but with visibly high granularity --- projectiles+  fly gradually over time with varying speeds and can be sidestepped+  or shot down; less so explosions that are swarms of projectile particles+  (turn-based just the same)+* time passes and factions pursue their goals on a few levels+  simultaneously, while other floors are frozen (but all are persistent)+* the same laws of simulated world apply to all factions and all actors,+  whether player-controlled or AI-controlled; e.g., the same field of view+  calculation, skill checks, equipment limitations, rules for item+  and terrain use+* combat mechanics is deterministic; randomness comes only from AI+  decisions and procedurally generated world+* there's (almost) no HP regeneration; attrition ensures all past (silly)+  decisions matter; HP of every actor starts at around half max+* each character has 10 uniform equipment slots, which fill quickly given+  that most melee weapons have cooldowns+* each faction has a single shared inventory of unlimited size,+  which has a physical location on the map and so can be ransacked -The heroes are marked on the map with symbols `@` and `1` through `9`.-Their goal is to explore the dungeon, battle the horrors within,-gather as much gold and gems as possible, and escape to tell the tale.+If the game window is too large for your screen or the game doesn't start+or you experience other technical issues, please consult+[README.md](https://github.com/LambdaHack/LambdaHack/blob/master/README.md)+or describe your problem on [Discord](https://discord.gg/87Ghnws)+or [Matrix](https://matrix.to/#/!HnbpAHMjOGHlYtrASl:mozilla.org)+or the issue tracker. Contributions of all kinds are welcome.+Please offer feedback to mikolaj.konarski@funktory.com or, preferably,+on any of the public forums. -The currently chosen party leader is highlighted on the screen-and his attributes are displayed at the bottommost status line,-which in its most complex form may look as follows. -    *@12 Adventurer  4d1+5% Calm: 20/60 HP: 33/50 Target: basilisk  [**___]+Starting your adventure+----------------------- -The line starts with the list of party members (unless only one member-resides on the currently displayed level) and the shortened name of the team.-Then comes the damage of the leader's weapon (but regardless of the figures,-each attack inflicts at least 1 damage), then his current and maximum-Calm (composure, focus, attentiveness), then his current and maximum-HP (hit points, health). At the end, the personal target of the leader-is described, in this case a basilisk monster, with hit points drawn as a bar.+Commands for starting a new game, saving and exiting the current game,+configuring convenience settings and toggling AI control of the party+are listed in the main menu, brought up by the Esc key.+Game difficulty level, from the new game setup menu, determines how hard+the survival in the game is. Each of the several named optional challenges+make the game additionally much harder, but usually simpler, as well.+Not that in-game hints don't take challenges into account+so kindly ignore, e.g., advice to use ranged combat more often,+if the chosen challenge bans ranged combat use altogether.+Of the convenience settings, the `suspect terrain` choice is of particular+interest, because it determines not only screen display of the floor map,+but also whether suspect tiles are considered for mouse go-to, auto-explore+and for the `C-?` command that marks the nearest unexplored position. -The other status line describes the current location in relation to the party.+Game scenarios, as ordered by their number, lead the player along+an optional story arc. The first two adventures double as tutorials+that offer rudimentary preparation for the main game, the long crawl.+They gradually introduce exploration, stealth and melee combat,+helping the player develop his repertoire of squad formations+and move patterns, suitable for different tactical contexts.+When the player loses, a defeat message for the scenario appears+with hints about strategies known to work in the given tactical context.+Alternatively, the player may postpone reading these messages and instead+try to puzzle out the tactics himself --- this is not so hard, as there are+not yet so many moving parts to figure out in the first two adventures. -    5  Lofty hall   [33% seen] Cursor: exact spot (71,12)  p15 l10+In the third scenario, the main 'crawl' game mode, the player starts+employing ranged combat, stealth, light sources, item and terrain alteration.+As soon as the player learns to navigate the initial levels of crawl,+but still dies a lot, it makes sense to return to the remaining+short adventures. They bring forth many extra game features+and tactics and prevent the player from missing half the fun by trying+to play the crawl just like a normal roguelike with spare heroes.+The extra scenarios continue the plotline from the initial tutorial adventures+in the form of flashbacks and eventually lead up to the events that start+the main crawl adventure. The training they provide has narrow focus,+drilling a particular skill set, even as exotic as opportunity fire+management, a frantic race to the exit and big asymmetric melee battles.+The challenge the scenarios offer may be, accordingly, quite extreme,+particularly at higher difficulty settings and when striving for high scores. -First comes the depth of the current level and its name.-Then the percentage of its explorable tiles already seen by the heroes.-The 'cursor' is the common target of the whole party,-directly manipulated with movement keys in the targeting mode.-At the end comes the length of the shortest path from the leader-to the cursor position and the straight-line distance between the two points.+The main adventure, the long crawl, is the only one that takes+place in a multi-floor setting, requiring lots of time to beat.+The focus is on resource management and survival,+including terrain transformation using tools, spotting environment+clues and guessing and countering opponents' strategies.+The player has a choice of exploring a single level at a time or portions+of many floors along a single staircase. On some levels he may explore+and loot with a single scout, eluding most opponents. On others he may be+forced to change pace and perform a complete exterminatory sweep+involving his whole party. On yet others, his best course of action may be+to defend a key location until the first wave of attackers is broken.+The large game arena calls for strategic thinking, including resource+management and area denial. Thus, the crawl scenario is the most replayable+adventure, but even the small ones can be refreshed by striving to beat+a high score and by ramping up the difficulty settings.  -Dungeon--------+Exploring the world+------------------- -The dungeon of the campaign mode game consists of 10 levels and each level-consists of a large number of tiles. The basic tile kinds are as follows.+The map of any particular adventure consists of one or many+levels and a level consists of a number of tiles with a particular+terrain kind on each. The game world is persistent, i.e., every time+the player visits a level during a single game, its layout is the same+(unless modified by other actors). -               dungeon terrain type               on-screen symbol-               ground                             .-               corridor                           #-               wall (horizontal and vertical)     - and |-               rock or tree                       O-               cache                              &-               stairs up                          <-               stairs down                        >-               open door                          | and --               closed door                        +-               bedrock                            blank+Letters and digits on the game screen are likely to represent actors.+On the other hand, terrain is depicted with non-letter and non-digit+characters and with zero `0`. Blocky solid symbols are likely to be+non-passable and/or not translucent terrain. White, cyan and green terrain+is usually inert, red is burning or trapped, blue activable or trapped,+magenta activable or searchable. -The game world is persistent, i.e., every time the player visits a level-during a single game, its layout is the same.+Items lying on the ground are represented with non-letter and non-digit+characters, just as terrain, though rarely with blocky symbols.+In case of doubt, one of the aiming commands (`/` and `KP_/`,+that is, `/` on the keypad) cycles through all visible and remembered+items on the level and another (`*` and `KP_*`, all with default keybindings)+through all foes. Also, pointing at a map position with MMB+(middle mouse button) displays a short description of its contents. +Pointing with RMB enters aiming mode, in which pointing again+or pressing Space key or MMB decreases detail level of the description.+If a foe or interesting terrain is being pointed at, tilde key `~` shows+the relevant lore details. The basic terrain kinds are as follows. -Commands---------+    terrain type                          on-screen symbol -You move throughout the level using the numerical keypad (left diagram)-or its compact laptop replacement (middle) or Vi text editor keys-(right, also known as "Rogue-like keys", which have to be enabled-in config.ui.ini).+    bush, transparent obstacle            %+    trap, ice obstacle                    ^ -                7 8 9          7 8 9          y k u-                 \|/            \|/            \|/-                4-5-6          u-i-o          h-.-l-                 /|\            /|\            /|\-                1 2 3          j k l          b j n+    wall (horizontal and vertical)        - and |+    bedrock                               blank+    tree, rock, man-made column           0+    rubble                                &+    stairs, exit up                       <+    stairs, exit down                     >+    closed door                           + -In targeting mode the keys above move the targeting cursor. In normal mode,-`SHIFT` (or `CTRL`) and a movement key make the current party leader-(and currently selected party members, if any) run in the indicated-direction, until anything of interest is spotted.-The '5', 'i' and '.' keys consume a turn and make you brace for combat,-which reduces any damage taken for a turn and makes it impossible-for foes to displace you. You displace enemies or friends by bumping-into them with SHIFT (or CTRL).+    open door (horizontal and vertical)   | and -+    corridor                              #+    ground                                .+    water, other fluid                    ~ -Melee, searching for secret doors, looting and opening closed doors-can be done by bumping into a monster, a wall and a door, respectively.-Few commands other than movement, 'g'etting an item from the floor,-'a'pplying an item and 'f'linging an item are necessary for casual play.-Some are provided only as specialized versions of more general commands-or as building blocks for more complex convenience commands,-e.g., the autoexplore command (key `X`) could be defined-by the player as a macro using `BACKSPACE`, `CTRL-?`, `;` and `V`.+    smoke, fog, open fire                 ;+    workshop, curtain, foliage            : -Below are the remaining keys for terrain exploration and alteration.+The four groups above, from top to bottom, block movement but not view,+block both, block neither, block view but not movement.+Additionally, each tile, regardless if open and if translucent,+may be permanently lit with ambient light or not. -                keys           command-                <              ascend a level-                CTRL-<         ascend 10 levels-                >              descend a level-                CTRL->         descend 10 levels-                ;              make one step towards the target-                :              go to target for 100 steps-                CTRL-:         go to target for 10 steps-                x              explore the closest unknown spot-                X              autoexplore 100 times-                CTRL-X         autoexplore 10 times-                R              rest (wait 100 times)-                CTRL-R         rest (wait 10 times)-                c              close door+Actors are marked with lower and upper case letters and with+characters `@` and `1` through `9` (but never `0`). Player-controlled+heroes are always bright white and at game start they are selected+(e.g., to run together) so they have a green highlight around their symbol.+If player manages to take control of animals or other actors, they retain+their letter and color, but gain a highlight as well. -Item-use related keys are as follows.+So, for example, the following map shows a room with a closed door,+full of actors, connected by a corridor with a room with an open door,+a pillar, a staircase down and rubble that obscures one of the corners.+The lowest row of the larger room is full of items. -                keys           command-                E              describe equipment of the leader-                P              describe backpack inventory of the leader-                S              describe the shared party stash-                G              describe items on the ground-                A              describe all owned items-                g and ,        get an item-                d              drop an item-                e              equip an item-                p              pack an item into inventory backpack-                s              stash and share an item-                a              activate applicable item-                q              quaff potion-                r              read scroll-                f              fling projectable item-                t              throw missile-                z              zap wand+    ------       ------+    |@19.|       |....&&+    |r...+#######-...0.>&&|+    |Ra..|       |[?!,)$"=|+    ------       ---------- -To make a ranged attack, as in the last few commands above,-you need to set your target first (however, initial target is set-automatically as soon as a monster comes into view). Once in targeting mode,-you can move the targeting cursor with arrow keys and switch focus-among enemies with `*` (or among friends, projectiles and enemies, depending-on targeting mode set by `/`). The details of the shared cursor position-and of the personal target are described at the bottom of the screen.-All targeting keys are listed below. -                keys           command-                KEYPAD_* and \ target enemy-                /              cycle targeting mode-                +              swerve targeting line-                -              unswerve targeting line-                BACKSPACE      clear target/cursor-                CTRL-?         target the closest unknown spot-                CTRL-I         target the closest item-                CTRL-{         target the closest stairs up-                CTRL-}         target the closest stairs down+Leading your heroes+------------------- -Here are the commands for automating the actions of one or more members-of the team.+The heroes are displayed on the map with bright white color (red if they are+seriously wounded) and symbols `@` and `1` through `9` (never `0`).+The currently chosen party pointman is highlighted on the map with yellow.+The easiest way to control your team is to run a short distance+with your pointman using Shift-direction or LMB, switch the pointman+with the Tab key, repeat. In open terrain, if you keep consistent distance+between teammates, this resembles the leap-frog infantry tactics,+in which the immobile team members cover the movement of the others.+For best effects, try to end each sprint behind cover or concealment+(note that a thin pillar is neither, but a single shadowed spot may be+enough to hide in the dark). -                keys           command-                =              select (or deselect) a party member-                _              deselect (or select) all on the level-                v              voice again the recorded commands-                V              voice the recorded commands 100 times-                CTRL-v         voice the recorded commands 1000 times-                CTRL-V         voice the recorded commands 10 times-                '              start recording commands-                CTRL-A         automate faction (ESC to retake control)+Pointman hero's attributes are displayed at the bottom-most status line which,+in its most complex form, looks as follows. -Assorted remaining keys and commands follow.+    *@12   2m/s Calm: 20/60 HP: 33/50 Pointman: Haskell Alvin   6d1+5% 4d1 -                keys           command-                ?              display help-                D              display player diary-                T              mark suspect terrain-                Z              mark visible zone-                C              mark smell clues-                TAB            cycle among party members on the level-                SHIFT-TAB      cycle among all party members-                SPACE          clear messages-                ESC            cancel action, open Main Menu-                RET            accept choice-                0--6           pick a new hero leader anywhere in the dungeon+The line starts with the list of party members, with the current pointman+highlighted in yellow. Most commands involve only the pointman, including+movement with keyboard or keypad or LMB (left mouse button).+If more heroes are selected (highlighted in green), they run together+whenever `:` or S-LMB (LMB while holding down Shift) over map area+is pressed, though that's usually not a precise enough method+of controlling a team. Any sleeping hero is highlighted in blue+and can be woken up by yelling with `%` key, which also taunts+and unnerves nearby enemies. -Commands for saving and exiting the current game, starting a new game, etc.,-are listed in the Main Menu, brought up by the `ESC` key.-Game difficulty setting affects hitpoints at birth for any actors-of any UI-using faction. For a person new to roguelikes, the Duel game mode-offers a gentle introduction. The subsequent game modes gradually introduce-squad combat, stealth, asymmetric battles and more game elements.+Next on the bottom-most status line is the pointman's current and maximum+Calm (morale, composure, focus, attentiveness), then his current+and maximum HP (hit points, health). The colon after "Calm" turning+into a dot signifies that the pointman is in a position without ambient+illumination, making stealthy conduct easier. A brace sign instead+of a colon after "HP" means the pointman is braced for combat+(see chapter [Moving and acting](#Moving-and-acting)). -                keys           command-                CTRL-x         save and exit-                CTRL-u         new Duel game-                CTRL-k         new Skirmish game-                CTRL-m         new Ambush game-                CTRL-b         new Battle game-                CTRL-a         new Campaign game-                CTRL-d         cycle next game difficulty+In the second half of the bottom-most status line, the pointman's name+is shown. Then come damage dice of the pointman's melee weapons and+the pointman's appendages, ordered by their power. The dice of the first+recharged weapon, the one that is going to be used now, is adorned with+percentage damage bonus collected from the whole equipment of the pointman.+If the dice are displayed with upper-case `D` instead of lower-case `d`,+the weapon has additional effects apart of the usual direct damage.+The nature of the effects can be appraised via the equipment outfit menu.+Only the most common piercing direct damage, denoted by the damage dice,+is affected by the percentage damage bonus. The other direct damage kinds,+such wounding and burning, are represented by extra added integers+and are not scaled by bonuses from melee skill nor maluses from+the opponent's armor. -There are also some debug, testing and cheat options and game modes-that can be specified on the command line when starting the game server.-Use at your own peril! :) Of these, you may find the screensaver game modes-the least spoilery and the most fun, e.g.:+Weapon damage and other item properties are displayed using+the dice notation `xdy`, which denotes `x` rolls of `y`-sided dice.+A variant written `xdLy` is additionally scaled by the level depth+in proportion to the maximal level depth (at the first level the result+is always one; it grows up to the full rolled value at the last level).+Section [Battling monsters](#Battling-monsters) below describes combat+resolution in detail, including the role of the percentage bonuses. -    LambdaHack --savePrefix test --newGame --noMore --maxFps 60 --automateAll --gameMode campaign --difficulty 1+The upper status line describes the currently visited level in relation+to the party. -The `--automateAll` option strictly corresponds to the `CTRL-A` command,-but most of the debug options have no corresponding commands.+    5  Lofty hall    [33% seen] dire basilisk    [__**] +First comes the depth of the current level and its name.+Then the percentage of its explorable tiles already seen by the heroes.+Then the common focus of the whole party, coming from the aiming crosshair+marked on the map with a red box and manipulated with mouse+or movement keys in aiming mode. In this example, the crosshair points+at a dire basilisk monster with its hit points drawn as a half-full bar. -Monsters---------+Instead of a monster, the aiming crosshair status area may describe+a position on the map, a recently spotted item on the floor or an item+in inventory selected for further action or, if none are available,+a summary of the team composition. For example, this form -Heroes are not alone in the dungeon. Monstrosities, natural-and out of this world, roam the dark caves and crawl from damp holes+    5  Lofty hall    [33% seen] spot (71,12)    p15 l10++indicates that the party is aiming at an exact spot on the map.+At the end of this example status line comes the length of the shortest+path from the pointman's position to the spot in crosshair and+the straight-line distance between the two points, one that a flung+projectile would travel if there were no obstacles.+++Moving and acting+-----------------++This chapter is a copy of the few initial pages of in-game help.+The in-game help is automatically generated based on a game's keybinding+content definitions and on overrides in the player's config file.+The remaining in-game help screens, not shown here, list all game+commands grouped by categories in detail.++Walk throughout a level with mouse or numeric keypad (right diagram below)+or the Vi editor keys (middle) or the left-hand movement keys (left). Run until+disturbed with Shift or Control. Go-to a position with LMB (left mouse button).+In aiming mode, the same keys (and mouse) move the aiming crosshair.++          q w e          y k u          7 8 9+           \|/            \|/            \|/+          a-s-d          h-.-l          4-5-6+           /|\            /|\            /|\+          z x c          b j n          1 2 3++Press `KP_5` (`5` on keypad) to wait, bracing for impact, which reduces any+damage taken and prevents displacement by foes. Press `S-KP_5` or `C-KP_5`+(the same key with Shift or Control) to lurk 0.1 of a turn, without bracing.++Displace enemies by running into them with Shift/Control or S-LMB. Search,+open, descend and melee by bumping into walls, doors, stairs and enemies.+The best, and not on cooldown, melee weapon is automatically chosen+for attack from your equipment and from among your body parts.++The following few commands, joined with the movement and running keys,+let you accomplish almost anything in the game, though not necessarily+with the fewest keystrokes. You can also play the game exclusively+with a mouse, or both mouse and keyboard (e.g., mouse for go-to+and terrain inspection and keyboard for everything else). Lastly,+you can select a command with arrows or mouse directly from the help+screen or the dashboard and execute it on the spot.++    keys         command+    I            manage the shared inventory stash+    g or ,       grab item(s)+    ESC          clear messages/open main menu/finish aiming+    RET or INS   open dashboard/accept target+    SPACE        clear messages/show history/cycle detail level+    TAB          cycle among all party members+    *            cycle crosshair among enemies+    /            cycle crosshair among items+    M            modify any admissible terrain+    %            yell or yawn and stop sleeping++Screen area and UI mode (exploration/aiming) determine mouse click+effects. Here we give an overview of effects of each button over+the game map area. The list includes not only left and right buttons,+but also the optional middle mouse button (MMB) and the mouse wheel,+which is also used over menus to move selection. For mice without RMB,+one can use Control key with LMB and for mice without MMB, one can use+C-RMB or C-S-LMB.++    keys         command (exploration/aiming)+    LMB          go to pointer for 25 steps/fling at enemy+    S-LMB        run to pointer collectively for 25 steps/fling at enemy+    RMB or C-LMB start aiming at enemy under pointer/cycle detail level+    S-RMB        modify terrain at pointer+    MMB or C-RMB snap crosshair to floor under pointer/cycle detail level+    WHEEL-UP     swerve the aiming line+    WHEEL-DN     unswerve the aiming line++Note that mouse is optional. Keyboard suffices, occasionally requiring+a lookup for an obscure command key in help screens.+++Battling monsters+-----------------++The life of heroes is full of danger. Monstrosities, natural+and out of this world, roam the dark corridors and crawl from damp holes day and night. While heroes pay attention to all other party members and take care to move one at a time, monsters don't care about each other-and all move at once, sometimes brutally colliding by accident.+and crowd and stampede all at once, sometimes brutally colliding by accident. -When the hero bumps into a monster or a monster attacks the hero,-melee combat occurs. The best equipped weapon or the best fighting organ-of each opponent is taken into account for calculating damage.-The damage the current hero can potentially inflict is displayed-at the bottom of the screen, but the actual damage depends also-on the monster's armor. Heroes and monsters running into one another-(with the `SHIFT` key) do not inflict damage, but change places.-This gives the opponent a free blow, but can improve the tactical situation-or aid escape.+Monsters are depicted on the map with letters. Upper case letters+are unique monsters, often guardians of special floors, resources+and keys to other areas. Lower case letters are the rabble.+If there are humans not from our team, they are marked+with `@` and `1` through `9` in other colours than white. -Slinging a missile at a target wounds it, consuming the weapon in the process.-You may propel any item in your equipment, inventory and on the ground-(press `?` to choose an item and press it again for a non-standard choice).-Only items of a few kinds inflict any damage, but some have other effects.-Whenever the monster's or hero's hit points reach zero, the combatant dies.-When the last hero dies, the game ends in defeat.+When a hero walks and bumps into a monster or a monster attacks+the hero, melee combat occurs. Hero *running* into and displacing+a monster (with the `Shift` key and, in case of keypad movement,+alternatively a `Control` key), does not involve inflicting a damage,+but only causes an exchange of places. This gives the opponent+a free blow, but can improve the tactical situation or aid escape.+In some circumstances actors are immune to the displacing,+e.g., when both parties form a continuous front-line. +In melee combat, the best recharged equipped weapon (including fighting+organs that are not on cooldown) is taken into account for determining+the damage and any extra effects of the blow. To calculate the damage+dealt, the outcome of the weapon's direct piercing damage dice roll+(but not any additional direct damage summands such as wounding or burning)+is multiplied by a percentage bonus. The total bonus is calculated+by taking the damage bonus (summed from the equipped items and organs+and conditions of the attacker, capped at 200%) minus the melee+armor modifier of the defender (capped at 200%, as well). However,+at least 5% of damage always gets through, even if the bonus is nominally+below -95%, so excessively strong armor acts only as a buffer against+high melee skill of opponents. -On Winning and Dying---------------------+The current pointman's melee bonus, armor modifier and other detailed+stats can be viewed in the skill menu, accessible via the `#` command,+which summarizes all the stats conferred by organs and conditions listed+in the organ menu, invoked by `@`. -You win the game if you escape the dungeon alive or, in game modes with-no exit opportunity, if you eliminate all opposition. In the former case,-your score is based on the gold and precious gems you've plundered,-plus a bonus based on the number of heroes you lost. In the latter case,-your score is based on the number of turns you spent overcoming your foes-and, as a bonus, the number of enemies you've subdued.+In ranged combat, the projectile is assumed to be attacking the defender+in melee, using itself as the weapon, with the usual dice and damage bonus.+This time, the *ranged* armor skill of the defender is taken into account+and, additionally, the speed of the missile (based on shape and weight)+figures in the calculation. You may propel any item from your inventory+(by default you are offered exclusively the appropriate items; press `+`+to open all choices). Only items of a few kinds inflict direct damage,+but some have other effects, beneficial, detrimental or mixed. -If all your heroes fall, you are awarded a score for your valiant deeds,-but no winning bonus. When, invariably, a new overconfident party-of adventurers storms the dungeon, they start from a new entrance,-with no experience and no equipment, and new, undaunted enemies-bar their way.+In-game detailed item descriptions contain melee and ranged damage estimates.+They do not take into account enemy armor nor damage from effects and,+if bonuses are not known, guesses are based on averages for the item kind+in question. The displayed figures are rounded, but the game internally+keeps track of minute fractions of HP for all actors in all calculations.++The combat stress drains Calm, gradually limiting viewing radius.+If Calm reaches zero and the actor is sufficiently impressed by his foes,+the actor defects and surrenders unto their domination. Whenever+the monster's or hero's hit points reach zero, the combatant falls down+and gets permanently incapacitated. When the last hero is disabled+or dominated, the adventure ends in defeat. Eliminating the last+monster at a given time not always results in victory.+++Attacking from a distance+-------------------------++Before the player presses `f` to make a ranged attack, he may spend time+moving and setting the aiming crosshair in aiming mode. However, this is+not often needed, since crosshair is set automatically as soon+as a monster comes into view and can still be adjusted for as long+as the missile to fling is not chosen.++Nevertheless, sometimes before flinging you want to examine+the level map tile by tile by moving the crosshair+or to assign persistent personal targets to party members.+The latter is essential in the rare cases when your henchmen+(non-pointman characters) can move autonomously or fire opportunistically+(via innate skills or rare equipment). Also, if your non-pointman character+is adjacent to more than one enemy, setting his target makes him melee+a particular foe.++You can enter the aiming mode with the `*` and `KP_*` keys that select+enemies or the `/` and `KP_/` keys that cycle among items on the level.+You can move crosshair with direction keys and assign a personal+target to the pointman with the `RET` key (Return, Enter).+The details about the shared crosshair position are displayed in a status+line close to the bottom of the screen, as explained in chapter+[Leading your heroes](#Leading-your-heroes) above. You cycle aiming+mode from foe to spot and to vector with the ``\`` key, which is useful,+e.g., when a monster vanishes but you still want to fling at its last+known position.+++Combat and Speed+----------------++During combat there are some more nuances to movement and actions that+are worth considering. Every action takes an amount of time (equal for+most of the actions). The time that it takes a unit to act is relative+to its speed and additionally affected by the team's communication overhead.++Any member of the squad that has not idled (either moved, used inventory,+attacked or lurked attentively) will incur a 10% speed penalty+on all members of the team on the same level, including themselves,+but excluding the pointman. This is a penalty for the time+and energy they had to spend to take note of any changes+that could be relevant to the squad and for the overhead needed+to communicate it and get it acknowledged by the other squad members.+In this way, a squad where 4 teammates take actions every turn will work+at 60% speed. By the same token, regardless of how numerous the team is,+never more than 10 normal speed teammates can act in the same turn+(the moves of the others are going to spill over to the next turn).++The pointman is an exception to this rule. The pointman may perform+melee attacks or any other action without incurring a team overhead penalty.+This may make it preferable to melee with the pointman, even though+any team member can melee and pointmen can also perform many other actions.+Also, this prevents a pointman from being slowed by the team residing+elsewhere on the level, making any solo pointman vs pointman duels fairer.++In a short scenario this may not be terribly relevant, but in longer+engagements the overhead can make a big difference in damage per second+that a team can put out. E.g., it's a crucial and context-dependent choice+whether to hurry towards a lonely meleeing teammate, thus lowering+the damage output, stay put, fling a projectile, or perhaps get the meleeing+teammate to retreat towards the team. Over a long run, such choices+influence the speed of HP attrition and if it outweighs the benefits+of exploration.+++Winning and dying+-----------------++You win an adventure if you escape the situation alive, which may prove+difficult, because your foes tend to gradually build up an ambush squad+blocking your escape route. On the other hand, in scenarios with no open+escape routes, the only way to survive is to eliminate all opposition,+which is not a small feat, either.++If escape without a fight to the death is possible, your score is based+in equal parts on the speed with which you manage to leave+the deadly environment and the proportion of gold and precious gems+(including the elixirs that are stored in precious crystal boxes)+you manage to plunder and carry off. Note that engaging in wanton slaughter+is counterproductive in such a setting, because it wastes time+and non-unique enemies never carry valuables, but stash them instead.++If killing all foes is required, your score is most influenced by the number+of turns you spent overcoming your foes (the quicker the victory, the better;+the slower the demise, the better). Bonus points, affected by the number+of heroes lost, are awarded only if you win. The score, in all cases, is+heavily modified by the chosen game difficulty, but not by any other challenges+(which are, however, distinctly announced in the high score listing).++When all your heroes fall, you lose, but you are going to invariably+see a new foolhardy party of adventurers clamoring to be led+into the unknown perils. They start their conquest afresh,+with no experience, no supplies for survival and no equipment,+and new undaunted enemies bar their way.+Lead the new hopeful explorers with wisdom and fortitude!+++FAQ+---++- Q: Why do I summon hostile animals all the time, why do I defect+to the enemy faction every level, why am I constantly sabotaging+my own adventure, what is going on?++A: Whenever anything bad happens, notice it and use it as a learning+experience. Especially if it happens often or periodically.+Check carefully the messages overlaid on the map and in history log,+look at your outfit, organs, stats. Observe coincidences.+Build conjectures. Deduce. Prevent. Adjust. Win. Whomever told you+bumping is enough, lied.++- Q: Why is my hero immobile?++A: Perhaps he's just sleeping (blue box indicates that)? If so,+you can wake him up with the `%` command. If he's not asleep,+his movement skill may be temporarily drained. Switch to another hero+or perform some other productive action different from walking+or wait with `KP_5` or rest with `R`.++- Q: Is autoexplore safe?++A: Not at all. It doesn't try to guess which hazardous terrain you want+to avoid and which to barge through, so be prepared to abort exploration+if open fire or slippery ground comes into view. Unless you have HP to spare.+Oh the other hand, running is very safe and go-to is rather safe.++- Q: Why does the percentage of explored tiles turn from 100% to 99%?++A: Apparently enemies transformed a tile from unexplorable terrain kind+to explorable. The new tile has never been seen by the player,+so the percentage is no longer at 100%.++- Q: Why when a single hero gets ambushed and is fighting at close quarters,+his distant teammates don't jointly come to his rescue.++A: The teammates wait for him to come back into the formation instead+so that they may assume a front line and then melee their foes together.+The immobile heroes are assumed to be pinned to their positions+by fear and shock, but also by their imperative to hold formation,+so as to defend an important position or avoid running piecemeal+into a trap or into friendly fire or avoid breaking concealment+and revealing their position or leaving a vantage point from which+they can observe and relay enemy movement. For untrained teams,+simultaneous synchronized squad movement is not feasible.+It would be practical if all squaddies had cameras, with a few drones+overhead for best effect, and if a team of off-site coordinators analyzed+the situation and micromanaged them all. This is not the case here.++- Q: Why is the noise I'm hearing "indistinct"?++A: That's because it's out of direct hearing range of each teammate+on the level, but ponderous enough to be perceived by all as vibrations+and echos from afar. Any other noise adjective indicates that the noise+is heard by at least one teammate and how far it is from the pointman+(who may or may not hear it directly, as signalled by his Calm drop).++- Q: Why are there two 'weakened' conditions in the organ menu of my hero?++A: Each team has a different recipe for their weakness brew.+Consequently, multiple affliction by the concoction from a single team+prolongs a single malady, but affliction by concoctions from many teams+causes concurrent ailments, with compounded effects, but independent+and short durations. The benefit of the mechanism is that+it's possible to tell the perpetrator team of any ailment.+The exceptions are the conditions that activate each turn, e.g., healing+(regeneration, various resistances that effectively cure each turn)+or wounding (poison). These are similar regardless of the team and so+the condition is always only prolonged.++- Q: Why is a harpoon in my shared inventory stash charging for hundreds+of turns?++A: This is an artifact of time running independently on each level.+Any ideas on how to improve this game mechanics are welcome.+A workaround is to drop and then pick up the item on the level+you want to use it. When picked up, it gets recharged after, randomly,+from one to two times the normal cooldown period of the item+and then recharges normally while it's used on this level.++- Q: Why the bottom line displays a weapon with a timeout to the right+of a weapon without timeout? Doesn't it mean the former is never used?++A: Yes, it's never used and, quite possibly, it's your party inventory+management mistake and if not, at least a very special situation+and the display turns your attention to it. Shuffle the equipment+among your team if you want the weapon to get used.
− GameDefinition/TieKnot.hs 
@@ -1,38 +0,0 @@--- | Here the knot of engine code pieces and the game-specific--- content definitions is tied, resulting in an executable game.-module TieKnot ( tieKnot ) where--import qualified Client.UI.Content.KeyKind as Content.KeyKind-import qualified Content.CaveKind-import qualified Content.FactionKind-import qualified Content.ItemKind-import qualified Content.ModeKind-import qualified Content.PlaceKind-import qualified Content.RuleKind-import qualified Content.TileKind-import Game.LambdaHack.Client (exeFrontend)-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli)-import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer)-import Game.LambdaHack.Server (mainSer)---- | Tie the LambdaHack engine client, server and frontend code--- with the game-specific content definitions, and run the game.-tieKnot :: [String] -> IO ()-tieKnot args =-  let -- Common content operations, created from content definitions.-      copsServer = Kind.COps-        { cocave    = Kind.createOps Content.CaveKind.cdefs-        , cofaction = Kind.createOps Content.FactionKind.cdefs-        , coitem    = Kind.createOps Content.ItemKind.cdefs-        , comode    = Kind.createOps Content.ModeKind.cdefs-        , coplace   = Kind.createOps Content.PlaceKind.cdefs-        , corule    = Kind.createOps Content.RuleKind.cdefs-        , cotile    = Kind.createOps Content.TileKind.cdefs-        }-      -- Client content operations.-      copsClient = Content.KeyKind.standardKeys-      -- A single frontend is currently started by the server,-      -- instead of each client starting it's own.-      startupFrontend = exeFrontend executorCli executorCli copsClient-  in mainSer args copsServer executorSer startupFrontend
GameDefinition/config.ui.default view
@@ -1,28 +1,141 @@-; ; This is a commented out copy of the default UI settings config file-; ; that is embedded in the binary.-; ; A user config file can overrides these options. The game looks for it at-; ; ~/.LambdaHack/config.ui.ini (or a similar path, depending on the OS).-; ; Warning: options are case-sensitive and only ';' for comments is permitted.+; This is a copy of the default UI settings config file+; that is embedded in the game binary. A user config file can override+; these options. Option names are case-sensitive and only ';' for comments+; is permitted.+;+; The game looks for the config file at the same path where saved games+; directory is located. E.g. on Linux the file is at+; ~/.LambdaHack/config.ui.ini+; and on Windows it can be at+; C:\Documents And Settings\user\Application Data\LambdaHack\config.ui.ini+; or at+; C:\Users\<username>\AppData\Roaming\LambdaHack\config.ui.ini+; or elsewhere. -; [extra_commands]-; ; A handy shorthand with Vi keys:-; Macro_1 = ("comma", ([CmdItem], Macro "" ["g"]))+[additional_commands]+; Angband compatibility (accept target)+Cmd_2 = ("KP_Insert", ([CmdAim], "", ByAimMode AimModeCmd {exploration = Dashboard, aiming = Accept}))+; Custom key rebinding example:+;+;   Cmd_anyName_youLike = ("a", ([CmdItem], "My Happy Cmd", Macro ["t"]))+;+; Explanation: to (t)rigger a consumable item for use, you normally use+;              the key press 't'.+; Suppose you would like to use the key press 'a' instead of 't'.+;   Cmd_anyName_youLike+;                  - can be anything starting with 'Cmd_' (the "Cmd_" prefix+;                    specifies that you are assigning a new command), as long+;                    as it doesn't conflict with a binding already defined+;   "a"            - the new key to use+;   [CmdItem]      - can either be [] or [CmdItem]. If using [CmdItem]+;                    the new keybinding will be displayed in the help menu+;                    in-game alongside other keys related to handling items.+;                    If there is no need to have the new binding displayed+;                    in the help menu, it is recommended to leave this empty []+;   "My Happy Cmd" - Is a name given to your binding, which would be dispayed+;                    in the help page in-game if you use 'CmdItem' from above+;   Macro ["t"]    - it specifies that you create a new command by combining+;                    or using the existing ones bound to keys. You can combine+;                    several key names within these squared brackets.+;                    Each key name must be enveloped in quotation marks.+;                    If you want to create a command that combines several+;                    simple actions, you should create a sequence of keys+;                    separated by the "," mark.+;                    For example, you may write something like ["r", "*"],+;                    which will remove all items from the shared inventory+;                    directly to the floor. Using Macro commands is the easiest+;                    way to create custom commands. -; [hero_names]-; HeroName_0 = ("Haskell Alvin", "he")-; HeroName_1 = ("Alonzo Barkley", "he")-; HeroName_2 = ("Ines Galenti", "she")-; HeroName_3 = ("Ernst Abraham", "he")-; HeroName_4 = ("Samuel Saunders", "he")-; HeroName_5 = ("Roger Robin", "he")-; HeroName_6 = ("Christopher Flatt", "he")+[hero_names]+HeroName_0 = ("Haskell Alvin", "he")+HeroName_1 = ("Alonzo Barkley", "he")+HeroName_2 = ("Inés Galenti", "she")+HeroName_3 = ("Ernst Abraham", "he")+HeroName_4 = ("Samuel Saunders", "he")+HeroName_5 = ("Roger Robin", "he")+HeroName_6 = ("Christopher Flatt", "he")+HeroName_7 = ("Simon Wise", "he")+HeroName_8 = ("Daniel Homer", "he")+HeroName_9 = ("Oleg Cracker", "he") -; [ui]-; movementViKeys_hjklyubn = False-; movementLaptopKeys_uk8o79jl = True-; font = "Terminus,Monospace normal normal normal normal 12"-; historyMax = 5000-; maxFps = 15-; noAnim = False-; runStopMsgs = False-[dummy]+[ui]+; Disable these to free up some keys, if you want to rebind commands+; and/or to avoid moving due to accidental key presses.+movementViKeys_hjklyubn = True+movementLeftHandKeys_axwdqezc = True+; recommended: "binary" or "dejavuBold"+chosenFontset = "dejavuBold"+; 1.0 means don't scale; 1.5, 2.0, 3.0 give good results, <0.7 very bad+; for scales < 1 try fontsets with bolder auxiliary fonts and/or HintingLight+allFontsScale = 1.0+; NotFullscreen (default), BigBorderlessWindow (preferred), ModeChange.+; For 1920×1080 fullscreen, set allFontsScale = 1.5 above.+fullscreenMode = NotFullscreen+; HP percent at which warning is emitted.+hpWarningPercent = 20+; Wrap messages after this column (measured in small font, if available).+; In LambdaHack, not enough height to fit longer messages if wrapped earlier.+msgWrapColumn = 80+; New historyMax takes effect after removal of savefiles.+; Looks best if is divisble by screenful of message (rheight - 4 = 20).+historyMax = 5000+; Frames per second throttled at this value.+maxFps = 24+; Animations when actors act are not displayed.+noAnim = False+; Hardwired commandline arguments to process.+overrideCmdline = ""++[fonts]+; the auxiliary fonts (the format is: kind name size hinting):+binaryRegular = FontProportional "BinarySansProLH-Regular.ttf.woff" 16 HintingHeavy+binaryBold = FontProportional "BinarySansProLH-Semibold.ttf.woff" 16 HintingHeavy+binaryMono = FontMonospace "BinaryCodeProLH-Bold.ttf.woff" 14 HintingHeavy+dejavuRegular = FontProportional "DejaVuLGCSans.ttf.woff" 15 HintingHeavy+dejavuBold = FontProportional "DejaVuLGCSans-Bold.ttf.woff" 13 HintingHeavy+dejavuMono = FontMonospace "Hack-Bold.ttf.woff" 13 HintingHeavy+; the map fonts (the format is: kind name size hinting cellSizeAdd):+; with allFontsScale < 1, try HintingLight for fuzzy, but less distorted shapes:+16x16xwScalable = FontMapScalable "16x16xw.woff" 16 HintingHeavy 0+; the map fonts (the format is: kind name cellSizeAdd):+16x16xwBitmap = FontMapBitmap "16x16xw.bdf" 0+8x8xbBitmap = FontMapBitmap "8x8xb.fnt" 2+8x8xBitmap = FontMapBitmap "8x8x.fnt" 2++[fontsets]+; This is a temporary hack around bitmap font breakage caused by+; https://gitlab.freedesktop.org/freetype/freetype/-/issues/1076+; In a couple of years this can be removed and the small bitmap fonts will work+; fine again, too.+dejavuBold = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwScalable", fontPropRegular = "dejavuBold", fontPropBold = "dejavuBold", fontMono = "dejavuMono"}++; best proportional:+binary = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwBitmap", fontPropRegular = "binaryRegular", fontPropBold = "binaryBold", fontMono = "binaryMono"}+dejavuBold_original = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwBitmap", fontPropRegular = "dejavuBold", fontPropBold = "dejavuBold", fontMono = "dejavuMono"}++; decent proportional:+binaryBold = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwBitmap", fontPropRegular = "binaryBold", fontPropBold = "binaryBold", fontMono = "binaryMono"}+dejavu = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwBitmap", fontPropRegular = "dejavuRegular", fontPropBold = "dejavuBold", fontMono = "dejavuMono"}++; monospace, for people that don't like proportional or many fonts:+binaryMono = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwBitmap", fontPropRegular = "binaryMono", fontPropBold = "binaryMono", fontMono = "binaryMono"}+dejavuMono = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwBitmap", fontPropRegular = "dejavuMono", fontPropBold = "dejavuMono", fontMono = "dejavuMono"}++; square:+16x16xw = FontSet {fontMapScalable = "16x16xwScalable", fontMapBitmap = "16x16xwBitmap", fontPropRegular = "", fontPropBold = "", fontMono = ""}+8x8xb = FontSet {fontMapScalable = "", fontMapBitmap = "8x8xbBitmap", fontPropRegular = "", fontPropBold = "", fontMono = ""}+8x8x = FontSet {fontMapScalable = "", fontMapBitmap = "8x8xBitmap", fontPropRegular = "", fontPropBold = "", fontMono = ""}++[message_colors]+; Prefixes of message class constructor names paired with colors.+; The first prefix that matches, wins.+;+; E.g., uncomment to make all messages white:+; Msg = White++[version]+; If an outdated config file mentions fonts that are not bundled with the game+; any more, the game crashes. To prevent that, one of the first three components+; of the game version should be bumped whenever fonts are changed.+; Configs from old versions are rejected, preventing the crash.+version = 0.11.0
+ GameDefinition/fonts/16x16x.fnt view

binary file changed (absent → 9389 bytes)

+ GameDefinition/fonts/16x16xw.bdf view
@@ -0,0 +1,9271 @@+STARTFONT 2.1+FONT -Angband-16x16x-Medium-R-Normal--16-120-100-100-C-80-ISO10646-1+SIZE 12 100 100+FONTBOUNDINGBOX 16 16 0 -3++STARTPROPERTIES 20+FAMILY_NAME "16x16x"+FOUNDRY "Angband"+WEIGHT_NAME "Medium"+SLANT "R"+SETWIDTH_NAME "Normal"+FONT_VERSION "1.0"+COPYRIGHT "Mikolaj Konarski, Leon Marrick and others 2019; released under GNU GPL-2"+CAP_HEIGHT 13+PIXEL_SIZE 16+POINT_SIZE 120+X_HEIGHT 8+RESOLUTION_X 100+RESOLUTION_Y 100+SPACING "C"+AVERAGE_WIDTH 80+WEIGHT 10+QUAD_WIDTH 16+DEFAULT_CHAR 32+FONT_DESCENT 3+FONT_ASCENT 13+ENDPROPERTIES++CHARS 385++STARTCHAR U+0007+ENCODING 7+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0180+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+0020+ENCODING 32+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+0021+ENCODING 33+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+03C0+03C0+03C0+03C0+0180+0180+0180+0000+0180+03C0+0180+0000+0000+ENDCHAR++STARTCHAR U+0022+ENCODING 34+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0630+0630+0630+0630+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+0023+ENCODING 35+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0C30+0C30+3FFC+3FFC+0C30+0C30+0C30+0C30+3FFC+3FFC+0C30+0C30+0000+0000+ENDCHAR++STARTCHAR U+0024+ENCODING 36+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0180+0FF0+1998+3180+3180+1980+0FF0+0198+018C+018C+3198+1FF0+0180+0000+0000+ENDCHAR++STARTCHAR U+0025+ENCODING 37+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+1C18+3618+2230+3660+1CC0+0180+0338+066C+0C44+186C+1838+0000+0000+0000+ENDCHAR++STARTCHAR U+0026+ENCODING 38+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07C0+0E60+1C30+0E60+07C0+0FC6+1C6C+3838+3838+1C7C+0FCE+0000+0000+0000+ENDCHAR++STARTCHAR U+0027+ENCODING 39+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0180+03C0+03C0+0180+0300+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+0028+ENCODING 40+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+00F0+01C0+0380+0700+0700+0700+0700+0700+0380+01C0+00F0+0000+0000+0000+ENDCHAR++STARTCHAR U+0029+ENCODING 41+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0F00+0380+01C0+00E0+00E0+00E0+00E0+00E0+01C0+0380+0F00+0000+0000+0000+ENDCHAR++STARTCHAR U+002A+ENCODING 42+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0630+0770+03E0+0FF8+0FF8+03E0+0770+0630+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+002B+ENCODING 43+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0180+0180+0180+0180+1FF8+1FF8+0180+0180+0180+0180+0000+0000+0000+ENDCHAR++STARTCHAR U+002C+ENCODING 44+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0180+03C0+03C0+0180+0700+0000+ENDCHAR++STARTCHAR U+002D+ENCODING 45+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+1FF8+1FF8+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+002E+ENCODING 46+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0180+03C0+03C0+0180+0000+0000+ENDCHAR++STARTCHAR U+002F+ENCODING 47+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+000C+001C+0030+0060+00C0+0180+0300+0600+0C00+3800+3000+0000+0000+0000+ENDCHAR++STARTCHAR U+0030+ENCODING 48+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1818+300C+300C+300C+318C+300C+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0031+ENCODING 49+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+00C0+01C0+0FC0+00C0+00C0+00C0+00C0+00C0+00C0+00C0+3FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+0032+ENCODING 50+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+3818+000C+000C+0038+01E0+0700+1C00+3000+3006+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0033+ENCODING 51+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07F0+1C18+000C+000C+0018+03F8+000C+0006+0006+380C+0FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0034+ENCODING 52+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+300C+300C+300C+300C+300C+1FFC+000C+000C+000C+000C+000C+0000+0000+0000+ENDCHAR++STARTCHAR U+0035+ENCODING 53+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFC+3000+3000+3000+3FF0+0018+000C+000C+000C+3818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0036+ENCODING 54+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07F0+0C18+1800+3000+3000+3FF0+3018+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0037+ENCODING 55+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFE+000E+001C+0038+0070+00E0+01C0+0380+0700+0E00+1C00+0000+0000+0000+ENDCHAR++STARTCHAR U+0038+ENCODING 56+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07E0+0C30+1818+1818+0C30+0FF0+1818+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0039+ENCODING 57+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1818+300C+300C+180C+0FFC+000C+000C+000C+3818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+003A+ENCODING 58+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0180+03C0+03C0+0180+0000+0000+0180+03C0+03C0+0180+0000+0000+ENDCHAR++STARTCHAR U+003B+ENCODING 59+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0180+03C0+03C0+0180+0000+0000+0180+03C0+03C0+0180+0700+0000+ENDCHAR++STARTCHAR U+003C+ENCODING 60+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0038+00E0+0380+0E00+3800+3800+0E00+0380+00E0+0038+0000+0000+0000+ENDCHAR++STARTCHAR U+003D+ENCODING 61+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+1FF8+0000+0000+1FF8+1FF8+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+003E+ENCODING 62+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+1C00+0700+01C0+0070+001C+001C+0070+01C0+0700+1C00+0000+0000+0000+ENDCHAR++STARTCHAR U+003F+ENCODING 63+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07F0+0C18+180C+000C+000C+0038+00E0+0180+0000+0180+03C0+0180+0000+0000+ENDCHAR++STARTCHAR U+0040+ENCODING 64+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1C18+380C+31FC+331C+331C+331C+31F8+3800+1C18+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0041+ENCODING 65+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FC0+01C0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0042+ENCODING 66+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FF0+1818+180C+180C+1818+1FF8+180C+1806+1806+180C+7FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0043+ENCODING 67+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF8+180C+3006+3000+3000+3000+3000+3000+3006+180C+0FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0044+ENCODING 68+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FE0+1830+1818+180C+180C+180C+180C+180C+1818+1830+7FE0+0000+0000+0000+ENDCHAR++STARTCHAR U+0045+ENCODING 69+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FFC+1806+1800+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0046+ENCODING 70+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FFC+1806+1800+1800+1800+1FF0+1800+1800+1800+1800+7E00+0000+0000+0000+ENDCHAR++STARTCHAR U+0047+ENCODING 71+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1818+300C+3000+3000+3000+30FF+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0048+ENCODING 72+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C1F+180C+180C+180C+180C+1FFC+180C+180C+180C+180C+7C1F+0000+0000+0000+ENDCHAR++STARTCHAR U+0049+ENCODING 73+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+004A+ENCODING 74+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+003F+000C+000C+000C+000C+000C+000C+000C+000C+7018+1FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+004B+ENCODING 75+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C3E+1818+1830+1860+18C0+1FC0+1860+1830+1818+180C+7C1F+0000+0000+0000+ENDCHAR++STARTCHAR U+004C+ENCODING 76+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7E00+1800+1800+1800+1800+1800+1800+1800+1800+1803+7FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+004D+ENCODING 77+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+780F+1C1C+1E3C+1B6C+19CC+188C+180C+180C+180C+180C+7C1F+0000+0000+0000+ENDCHAR++STARTCHAR U+004E+ENCODING 78+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+783F+180C+1C0C+1E0C+1B0C+198C+18CC+186C+183C+181C+7E0C+0000+0000+0000+ENDCHAR++STARTCHAR U+004F+ENCODING 79+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07E0+0C30+1818+300C+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0050+ENCODING 80+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FF8+180C+1806+1806+180C+1FF8+1800+1800+1800+1800+7E00+0000+0000+0000+ENDCHAR++STARTCHAR U+0051+ENCODING 81+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07E0+0C30+1818+300C+300C+300C+300C+300C+19D8+0CF0+07E0+0038+0000+0000+ENDCHAR++STARTCHAR U+0052+ENCODING 82+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FF0+1818+180C+180C+1818+1FF0+18C0+1860+1830+1818+7C3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0053+ENCODING 83+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF8+180C+3000+3000+1800+0FF8+000C+0006+0006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0054+ENCODING 84+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFC+6186+0180+0180+0180+0180+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0055+ENCODING 85+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+0056+ENCODING 86+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C1F+180C+180C+0C18+0C18+0630+0630+0360+0360+01C0+01C0+0000+0000+0000+ENDCHAR++STARTCHAR U+0057+ENCODING 87+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C1F+180C+180C+180C+180C+188C+19CC+1B6C+1E3C+1C1C+180C+0000+0000+0000+ENDCHAR++STARTCHAR U+0058+ENCODING 88+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C3E+1818+0C30+0660+03C0+0180+03C0+0660+0C30+1818+7C3E+0000+0000+0000+ENDCHAR++STARTCHAR U+0059+ENCODING 89+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C3E+1818+0C30+0660+03C0+0180+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+005A+ENCODING 90+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFE+601C+0038+0070+00E0+01C0+0380+0700+0E00+1C03+3FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+005B+ENCODING 91+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07F0+0600+0600+0600+0600+0600+0600+0600+0600+0600+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+005C+ENCODING 92+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3000+3800+0C00+0600+0300+0180+00C0+0060+0030+001C+000C+0000+0000+0000+ENDCHAR++STARTCHAR U+005D+ENCODING 93+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FE0+0060+0060+0060+0060+0060+0060+0060+0060+0060+0FE0+0000+0000+0000+ENDCHAR++STARTCHAR U+005E+ENCODING 94+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+03C0+0660+0C30+1818+300C+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+005F+ENCODING 95+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+7FFE+7FFE+0000+0000+ENDCHAR++STARTCHAR U+0060+ENCODING 96+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0700+0380+01C0+00E0+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+0061+ENCODING 97+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0062+ENCODING 98+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7800+1800+1800+1800+1FF8+180C+1806+1806+1806+1C06+73FC+0000+0000+0000+ENDCHAR++STARTCHAR U+0063+ENCODING 99+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+300C+6000+6000+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0064+ENCODING 100+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+003C+000C+000C+000C+0FFC+180C+300C+300C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0065+ENCODING 101+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0066+ENCODING 102+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+01FC+0606+0600+7FF8+0600+0600+0600+0600+0600+3FC0+0000+0000+0000+ENDCHAR++STARTCHAR U+0067+ENCODING 103+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0FE7+181C+300C+300C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0068+ENCODING 104+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7800+1800+1800+1800+1FF8+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+0069+ENCODING 105+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+00C0+00C0+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+006A+ENCODING 106+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+000C+000C+0000+0000+03FC+000C+000C+000C+000C+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+006B+ENCODING 107+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7800+1800+1800+181E+1830+1860+18C0+1FE0+1830+1818+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+006C+ENCODING 108+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+FE00+0600+0600+0600+0600+0600+0600+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+006D+ENCODING 109+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+7E70+318C+318C+318C+318C+318C+318C+718F+0000+0000+0000+ENDCHAR++STARTCHAR U+006E+ENCODING 110+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+006F+ENCODING 111+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0070+ENCODING 112+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+73F8+1C0C+1806+1806+1806+1806+1FFC+1800+1800+1800+7800+ENDCHAR++STARTCHAR U+0071+ENCODING 113+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0FEC+181C+300C+300C+300C+300C+1FFC+000C+000C+000C+000F+ENDCHAR++STARTCHAR U+0072+ENCODING 114+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+79FC+0E07+0C00+0C00+0C00+0C00+0C00+7F80+0000+0000+0000+ENDCHAR++STARTCHAR U+0073+ENCODING 115+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0FFC+3807+3800+0FF8+000C+0006+7006+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0074+ENCODING 116+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0600+0600+0600+7FF8+0600+0600+0600+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+0075+ENCODING 117+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0076+ENCODING 118+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+7C1F+180C+180C+0C18+0630+0360+01C0+01C0+0000+0000+0000+ENDCHAR++STARTCHAR U+0077+ENCODING 119+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+780F+180C+180C+180C+19CC+19CC+0F78+0630+0000+0000+0000+ENDCHAR++STARTCHAR U+0078+ENCODING 120+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+7C1F+180C+0630+01C0+01C0+0630+180C+7C1F+0000+0000+0000+ENDCHAR++STARTCHAR U+0079+ENCODING 121+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+783F+180C+180C+180C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+007A+ENCODING 122+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+3FFE+600E+0038+00E0+0380+0E00+3803+3FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+007B+ENCODING 123+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+00F0+0180+0180+0180+0300+0E00+0300+0180+0180+0180+00F0+0000+0000+0000+ENDCHAR++STARTCHAR U+007C+ENCODING 124+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0180+0180+0180+0180+0180+0180+0180+0180+0180+0180+0000+0000+ENDCHAR++STARTCHAR U+007D+ENCODING 125+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0F00+0180+0180+0180+00C0+0070+00C0+0180+0180+0180+0F00+0000+0000+0000+ENDCHAR++STARTCHAR U+007E+ENCODING 126+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0F0C+1F9C+39F8+30F0+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00A0+ENCODING 160+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00A1+ENCODING 161+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+03C0+0180+0000+0180+0180+0180+03C0+03C0+03C0+03C0+0180+0000+0000+ENDCHAR++STARTCHAR U+00A2+ENCODING 162+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0FF8+198C+3180+3180+3180+3180+198C+0FF8+0180+0180+0000+0000+ENDCHAR++STARTCHAR U+00A3+ENCODING 163+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+01F0+03F8+071C+060C+1FC0+1FC0+0600+1E00+3F00+3780+3FF8+1CF8+0000+0000+0000+ENDCHAR++STARTCHAR U+00A4+ENCODING 164+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0180+05A0+0A50+05A0+1BD8+1BD8+05A0+0A50+05A0+0180+0000+0000+0000+ENDCHAR++STARTCHAR U+00A5+ENCODING 165+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+300C+381C+1C38+0E70+07E0+1FF8+1FF8+0180+1FF8+1FF8+0180+0180+0000+0000+0000+ENDCHAR++STARTCHAR U+00A6+ENCODING 166+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0300+0300+0300+0300+0300+0000+0000+0300+0300+0300+0300+0300+0000+0000+ENDCHAR++STARTCHAR U+00A7+ENCODING 167+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+07F0+0FF8+1C08+1800+1FE0+17F0+1018+1808+0FE8+07F8+0018+1038+1FF0+0FE0+0000+ENDCHAR++STARTCHAR U+00A8+ENCODING 168+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0660+0660+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00A9+ENCODING 169+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1818+33CC+366C+360C+360C+360C+366C+33CC+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+00AA+ENCODING 170+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1830+1830+0FFC+0000+1FFC+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00AB+ENCODING 171+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+038E+0E38+38E0+0E38+038E+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00AC+ENCODING 172+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+3FFC+000C+000C+000C+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00AE+ENCODING 174+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1818+37CC+346C+342C+37CC+358C+34CC+346C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+00AF+ENCODING 175+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03E0+03E0+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00B0+ENCODING 176+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+07E0+0C30+0C30+07E0+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00B1+ENCODING 177+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0180+0180+0180+1FF8+1FF8+0180+0180+0180+0000+1FF8+1FF8+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00B2+ENCODING 178+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+07F0+1C18+0038+00E0+0380+0E00+1FF8+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00B3+ENCODING 179+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+07F0+1C18+0018+01F0+0018+1C18+07F0+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00B4+ENCODING 180+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0100+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00B5+ENCODING 181+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0C0C+0C0C+0C0C+0C0C+0C0C+0C0C+0C1C+0FE7+0C00+0C00+3800+ENDCHAR++STARTCHAR U+00B6+ENCODING 182+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+1FFC+3E30+3E30+3E30+1E30+0630+0630+0630+0630+0630+0630+0000+0000+0000+ENDCHAR++STARTCHAR U+00B7+ENCODING 183+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0180+0180+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00B8+ENCODING 184+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+0000+00C0+0060+01C0+ENDCHAR++STARTCHAR U+00B9+ENCODING 185+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0180+0780+0180+0180+0180+0180+1FF8+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00BA+ENCODING 186+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1818+1818+0FF0+0000+1FF8+0000+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00BB+ENCODING 187+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+38E0+0E38+038E+0E38+38E0+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00BC+ENCODING 188+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+1800+7800+1800+181C+1870+01C0+0700+1C66+7066+007E+0006+0006+0000+0000+ENDCHAR++STARTCHAR U+00BD+ENCODING 189+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+1800+7800+1800+181C+1870+01C0+0700+1C7C+7006+003C+0060+007E+0000+0000+ENDCHAR++STARTCHAR U+00BE+ENCODING 190+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C00+0600+1E00+061C+7C70+01C0+0700+1C66+7066+007E+0006+0006+0000+0000+ENDCHAR++STARTCHAR U+00BF+ENCODING 191+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+03C0+0180+0000+0180+00E0+0038+000C+000C+180C+0C18+07F0+0000+0000+ENDCHAR++STARTCHAR U+00C0+ENCODING 192+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+00C0+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+00C1+ENCODING 193+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+00C2+ENCODING 194+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+00C3+ENCODING 195+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+05C0+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+00C4+ENCODING 196+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0630+0630+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+00C5+ENCODING 197+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03C0+0180+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+00C6+ENCODING 198+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FFC+03C6+06C0+04C0+0CC0+0FF8+18C0+18C0+30C0+30C6+79FC+0000+0000+0000+ENDCHAR++STARTCHAR U+00C7+ENCODING 199+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF8+180C+3006+3000+3000+3000+3000+3000+3006+180C+0FF8+00C0+0060+01C0+ENDCHAR++STARTCHAR U+00C8+ENCODING 200+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+00C0+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00C9+ENCODING 201+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00CA+ENCODING 202+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00CB+ENCODING 203+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0660+0660+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00CC+ENCODING 204+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0300+0180+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00CD+ENCODING 205+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00CE+ENCODING 206+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00CF+ENCODING 207+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0660+0660+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00D0+ENCODING 208+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FE0+1830+1818+180C+180C+7F8C+180C+180C+1818+1830+7FE0+0000+0000+0000+ENDCHAR++STARTCHAR U+00D1+ENCODING 209+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+05C0+0000+783F+1C0C+1E0C+1B0C+198C+18CC+186C+183C+181C+7E0C+0000+0000+0000+ENDCHAR++STARTCHAR U+00D2+ENCODING 210+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0300+0180+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+00D3+ENCODING 211+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+00D4+ENCODING 212+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+00D5+ENCODING 213+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+05C0+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+00D6+ENCODING 214+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0660+0660+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+00D7+ENCODING 215+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0C30+0E70+07E0+03C0+03C0+07E0+0E70+0C30+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00D8+ENCODING 216+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07EC+0C18+1830+3068+30CC+318C+330C+360C+1C18+1830+37E0+0000+0000+0000+ENDCHAR++STARTCHAR U+00D9+ENCODING 217+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+00C0+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+00DA+ENCODING 218+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+00DB+ENCODING 219+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+00DC+ENCODING 220+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0630+0630+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+00DD+ENCODING 221+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+7C3E+1818+0C30+0660+03C0+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+00DE+ENCODING 222+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+1800+1800+1FE0+1FF0+1838+1818+1818+1838+1FF0+1FE0+1800+1800+0000+0000+0000+ENDCHAR++STARTCHAR U+00DF+ENCODING 223+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0FF8+1FFC+181C+181C+1838+1870+18E0+1870+1838+181C+187C+19F8+0000+0000+0000+ENDCHAR++STARTCHAR U+00E0+ENCODING 224+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0300+0180+0080+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00E1+ENCODING 225+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00E2+ENCODING 226+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00E3+ENCODING 227+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0360+05C0+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00E4+ENCODING 228+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0660+0660+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00E5+ENCODING 229+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+0140+0080+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00E6+ENCODING 230+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+3E7C+63C6+0186+1FFC+3180+6180+61C6+3E7C+0000+0000+0000+ENDCHAR++STARTCHAR U+00E7+ENCODING 231+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+300C+6000+6000+6000+6000+3007+1FFC+00C0+0060+01C0+ENDCHAR++STARTCHAR U+00E8+ENCODING 232+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0300+0180+0080+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00E9+ENCODING 233+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00EA+ENCODING 234+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00EB+ENCODING 235+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0660+0660+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+00EC+ENCODING 236+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0300+0180+0080+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+00ED+ENCODING 237+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0060+00C0+0080+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+00EE+ENCODING 238+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+00EF+ENCODING 239+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0330+0330+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+00F0+ENCODING 240+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+0180+06C0+0060+0030+0FF8+181C+300C+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+00F1+ENCODING 241+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+01B0+02E0+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+00F2+ENCODING 242+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0300+0180+0080+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+00F3+ENCODING 243+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+00F4+ENCODING 244+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+00F5+ENCODING 245+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0360+05C0+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+00F6+ENCODING 246+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0660+0660+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+00F7+ENCODING 247+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0180+0180+0000+1FF8+1FF8+0000+0180+0180+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+00F8+ENCODING 248+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0FFA+180E+303C+30E6+3386+1E06+380C+2FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+00F9+ENCODING 249+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0300+0180+0080+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00FA+ENCODING 250+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00FB+ENCODING 251+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00FC+ENCODING 252+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0660+0660+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+00FD+ENCODING 253+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+783F+180C+180C+180C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+00FE+ENCODING 254+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+1800+1800+1800+1FE0+1FF8+1818+1818+1FF8+1FE0+1800+1800+1800+0000+ENDCHAR++STARTCHAR U+00FF+ENCODING 255+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0660+0660+0000+783F+180C+180C+180C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0100+ENCODING 256+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03E0+03E0+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0101+ENCODING 257+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0102+ENCODING 258+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0220+01C0+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0103+ENCODING 259+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0220+01C0+0000+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0104+ENCODING 260+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FC0+01C0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+000C+0018+000E+ENDCHAR++STARTCHAR U+0105+ENCODING 261+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+000C+0018+000E+ENDCHAR++STARTCHAR U+0106+ENCODING 262+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+0FF8+180C+3006+3000+3000+3000+3000+3006+180C+0FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0107+ENCODING 263+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+1FF8+300C+6000+6000+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0108+ENCODING 264+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+0FF8+180C+3006+3000+3000+3000+3000+3006+180C+0FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0109+ENCODING 265+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+1FF8+300C+6000+6000+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+010A+ENCODING 266+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0180+0000+0FF8+180C+3006+3000+3000+3000+3000+3006+180C+0FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+010B+ENCODING 267+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0000+1FF8+300C+6000+6000+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+010C+ENCODING 268+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+0FF8+180C+3006+3000+3000+3000+3000+3006+180C+0FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+010D+ENCODING 269+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+1FF8+300C+6000+6000+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+010E+ENCODING 270+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+06C0+0380+0000+7FE0+1830+1818+180C+180C+180C+180C+1818+1830+7FE0+0000+0000+0000+ENDCHAR++STARTCHAR U+010F+ENCODING 271+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0001+007B+001A+0018+0018+1FF8+3018+6018+6018+6018+6038+3FCE+0000+0000+0000+ENDCHAR++STARTCHAR U+0110+ENCODING 272+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FE0+1830+1818+180C+180C+7F8C+180C+180C+1818+1830+7FE0+0000+0000+0000+ENDCHAR++STARTCHAR U+0111+ENCODING 273+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+003C+000C+00FF+000C+0FFC+180C+300C+300C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0112+ENCODING 274+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03E0+03E0+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0113+ENCODING 275+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0114+ENCODING 276+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0220+01C0+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0115+ENCODING 277+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0220+01C0+0000+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0116+ENCODING 278+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0180+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0117+ENCODING 279+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0118+ENCODING 280+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FFC+1806+1800+1800+1800+1FF0+1800+1800+1800+1806+7FFC+00C0+0180+00E0+ENDCHAR++STARTCHAR U+0119+ENCODING 281+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+00C0+0180+00E0+ENDCHAR++STARTCHAR U+011A+ENCODING 282+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+011B+ENCODING 283+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+011C+ENCODING 284+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+0FF0+1818+300C+3000+3000+30FF+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+011D+ENCODING 285+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+0FE7+181C+300C+300C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+011E+ENCODING 286+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0220+01C0+0000+0FF0+1818+300C+3000+3000+30FF+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+011F+ENCODING 287+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0220+01C0+0000+0000+0FE7+181C+300C+300C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0120+ENCODING 288+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0180+0000+0FF0+1818+300C+3000+3000+30FF+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0121+ENCODING 289+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0180+0180+0000+0000+0FE7+181C+300C+300C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0122+ENCODING 290+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF0+1818+300C+3000+3000+3000+30FF+300C+300C+1818+0FF0+0180+00C0+0380+ENDCHAR++STARTCHAR U+0123+ENCODING 291+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0180+0000+0FE7+181C+300C+300C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0124+ENCODING 292+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+7C1F+180C+180C+180C+1FFC+180C+180C+180C+180C+7C1F+0000+0000+0000+ENDCHAR++STARTCHAR U+0125+ENCODING 293+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0700+0D80+0000+7800+1800+1800+1FF8+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+0126+ENCODING 294+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C1F+180C+3FFE+180C+180C+1FFC+180C+180C+180C+180C+7C1F+0000+0000+0000+ENDCHAR++STARTCHAR U+0127+ENCODING 295+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7800+1800+7F80+1800+1FF8+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+0128+ENCODING 296+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+05C0+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0129+ENCODING 297+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0360+05C0+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+012A+ENCODING 298+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+07C0+07C0+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+012B+ENCODING 299+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+012C+ENCODING 300+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0440+0380+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+012D+ENCODING 301+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0220+01C0+0000+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+012E+ENCODING 302+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0180+0300+01C0+ENDCHAR++STARTCHAR U+012F+ENCODING 303+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+00C0+00C0+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+00C0+0180+00E0+ENDCHAR++STARTCHAR U+0130+ENCODING 304+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0180+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0131+ENCODING 305+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+0134+ENCODING 308+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+001C+0036+0000+003F+000C+000C+000C+000C+000C+000C+000C+7018+1FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+0135+ENCODING 309+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0008+001C+0036+0000+0000+03FC+000C+000C+000C+000C+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0136+ENCODING 310+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C3E+1818+1830+1860+18C0+1FC0+1860+1830+1818+180C+7C1F+0180+0180+0700+ENDCHAR++STARTCHAR U+0137+ENCODING 311+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7800+1800+1800+181E+1830+1860+18C0+1FE0+1830+1818+7E3F+0180+0180+0700+ENDCHAR++STARTCHAR U+0138+ENCODING 312+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+781E+1830+1860+18C0+1FE0+1830+1818+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0139+ENCODING 313+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0600+0C00+0000+7E00+1800+1800+1800+1800+1800+1800+1800+1803+7FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+013A+ENCODING 314+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0300+0000+FE00+0600+0600+0600+0600+0600+0600+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+013B+ENCODING 315+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7E00+1800+1800+1800+1800+1800+1800+1800+1800+1803+7FFE+00C0+0060+01C0+ENDCHAR++STARTCHAR U+013C+ENCODING 316+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+FE00+0600+0600+0600+0600+0600+0600+0600+0607+01FC+00C0+0060+01C0+ENDCHAR++STARTCHAR U+013D+ENCODING 317+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0020+0060+7E40+1800+1800+1800+1800+1800+1800+1800+1800+1803+7FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+013E+ENCODING 318+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0020+0060+FE40+0600+0600+0600+0600+0600+0600+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+013F+ENCODING 319+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7E00+1800+1800+1800+18C0+18C0+1800+1800+1800+1803+7FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+0140+ENCODING 320+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+FE00+0600+0600+0630+0630+0600+0600+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+0141+ENCODING 321+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7E00+1800+1800+18C0+1B80+1E00+3800+7800+1800+1803+7FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+0142+ENCODING 322+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+FE00+0600+0600+06C0+0780+0E00+1E00+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+0143+ENCODING 323+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+783F+1C0C+1E0C+1B0C+198C+18CC+186C+183C+181C+7E0C+0000+0000+0000+ENDCHAR++STARTCHAR U+0144+ENCODING 324+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0060+00C0+0080+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+0145+ENCODING 325+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+783F+180C+1C0C+1E0C+1B0C+198C+18CC+186C+183C+181C+7E0C+0018+000C+0038+ENDCHAR++STARTCHAR U+0146+ENCODING 326+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0018+000C+0038+ENDCHAR++STARTCHAR U+0147+ENCODING 327+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+783F+1C0C+1E0C+1B0C+198C+18CC+186C+183C+181C+7E0C+0000+0000+0000+ENDCHAR++STARTCHAR U+0148+ENCODING 328+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+0149+ENCODING 329+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+3000+7800+3000+6000+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+014A+ENCODING 330+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+783F+180C+1C0C+1E0C+1B0C+198C+18CC+186C+183C+181C+7E0C+0018+0070+0000+ENDCHAR++STARTCHAR U+014B+ENCODING 331+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0018+0070+0000+ENDCHAR++STARTCHAR U+014C+ENCODING 332+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03E0+03E0+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+014D+ENCODING 333+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+014E+ENCODING 334+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0220+01C0+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+014F+ENCODING 335+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0220+01C0+0000+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0150+ENCODING 336+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+06C0+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0151+ENCODING 337+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0330+0660+0440+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0152+ENCODING 338+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FFC+18C6+30C0+30C0+30C0+30F8+30C0+30C0+30C0+18C6+0FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0153+ENCODING 339+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1E7C+33C6+6186+61FC+6180+6180+33C6+1E7C+0000+0000+0000+ENDCHAR++STARTCHAR U+0154+ENCODING 340+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+7FF0+1818+180C+180C+1FF8+18C0+1860+1830+1818+7C3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0155+ENCODING 341+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0030+0060+0040+0000+79FC+0E07+0C00+0C00+0C00+0C00+0C00+7F80+0000+0000+0000+ENDCHAR++STARTCHAR U+0156+ENCODING 342+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FF0+1818+180C+180C+1818+1FF0+18C0+1860+1830+1818+7C3F+0180+0180+0700+ENDCHAR++STARTCHAR U+0157+ENCODING 343+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+79FC+0E07+0C00+0C00+0C00+0C00+0C00+7F80+0C00+0600+1C00+ENDCHAR++STARTCHAR U+0158+ENCODING 344+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+7FF0+1818+180C+180C+1FF8+18C0+1860+1830+1818+7C3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0159+ENCODING 345+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+01B0+00E0+0040+0000+79FC+0E07+0C00+0C00+0C00+0C00+0C00+7F80+0000+0000+0000+ENDCHAR++STARTCHAR U+015A+ENCODING 346+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+0FF8+180C+3000+3000+1FF8+000C+0006+0006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+015B+ENCODING 347+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0060+00C0+0080+0000+0FFC+3807+3800+0FF8+000C+0006+7006+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+015C+ENCODING 348+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+0FF8+180C+3000+3000+1FF8+000C+0006+0006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+015D+ENCODING 349+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0040+00E0+01B0+0000+0FFC+3807+3800+0FF8+000C+0006+7006+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+015E+ENCODING 350+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF8+180C+3000+3000+1800+0FF8+000C+0006+0006+300C+1FF8+0180+00C0+0380+ENDCHAR++STARTCHAR U+015F+ENCODING 351+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0FFC+3807+3800+0FF8+000C+0006+7006+1FFC+00C0+0060+01C0+ENDCHAR++STARTCHAR U+0160+ENCODING 352+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+0FF8+180C+3000+3000+1FF8+000C+0006+0006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0161+ENCODING 353+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+0FFC+3807+3800+0FF8+000C+0006+7006+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0162+ENCODING 354+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFC+6186+0180+0180+0180+0180+0180+0180+0180+0180+07E0+0180+00C0+0380+ENDCHAR++STARTCHAR U+0163+ENCODING 355+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0600+0600+0600+7FF8+0600+0600+0600+0600+0607+01FC+0060+0030+00E0+ENDCHAR++STARTCHAR U+0164+ENCODING 356+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+3FFC+6186+0180+0180+0180+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0165+ENCODING 357+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0020+0060+0640+0600+0600+7FF8+0600+0600+0600+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+0166+ENCODING 358+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFC+6186+0180+0180+0FF0+0180+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0167+ENCODING 359+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0600+0600+0600+7FF8+0600+0600+1FE0+0600+0607+01FC+0000+0000+0000+ENDCHAR++STARTCHAR U+0168+ENCODING 360+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01B0+02E0+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+0169+ENCODING 361+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0360+05C0+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+016A+ENCODING 362+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03E0+03E0+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+016B+ENCODING 363+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+016C+ENCODING 364+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0220+01C0+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+016D+ENCODING 365+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0220+01C0+0000+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+016E+ENCODING 366+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03C0+0180+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+016F+ENCODING 367+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0100+0280+0100+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0170+ENCODING 368+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01B0+0360+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+0171+ENCODING 369+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0330+0660+0440+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0172+ENCODING 370+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+00C0+0180+00E0+ENDCHAR++STARTCHAR U+0173+ENCODING 371+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+000C+0018+000E+ENDCHAR++STARTCHAR U+0174+ENCODING 372+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+7C1F+180C+180C+180C+188C+19CC+1B6C+1E3C+1C1C+180C+0000+0000+0000+ENDCHAR++STARTCHAR U+0175+ENCODING 373+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+780F+180C+180C+180C+19CC+19CC+0F78+0630+0000+0000+0000+ENDCHAR++STARTCHAR U+0176+ENCODING 374+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0360+0000+7C3E+1818+0C30+0660+03C0+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0177+ENCODING 375+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0080+01C0+0360+0000+783F+180C+180C+180C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0178+ENCODING 376+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0660+0660+0000+7C3E+1818+0C30+0660+03C0+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0179+ENCODING 377+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+3FFC+6038+0070+00E0+01C0+0380+0700+0E00+1C06+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+017A+ENCODING 378+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+3FFE+600E+0038+00E0+0380+0E00+3803+3FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+017B+ENCODING 379+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0180+0000+3FFC+6038+0070+00E0+01C0+0380+0700+0E00+1C06+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+017C+ENCODING 380+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0000+3FFE+600E+0038+00E0+0380+0E00+3803+3FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+017D+ENCODING 381+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+3FFC+6038+0070+00E0+01C0+0380+0700+0E00+1C06+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+017E+ENCODING 382+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+3FFE+600E+0038+00E0+0380+0E00+3803+3FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+0180+ENCODING 384+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7800+1800+7F80+1800+1FF8+180C+1806+1806+1806+1C06+73FC+0000+0000+0000+ENDCHAR++STARTCHAR U+0181+ENCODING 385+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FF0+4C18+4C0C+6C0C+0C18+0FF8+0C0C+0C06+0C06+0C0C+3FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0187+ENCODING 391+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+000E+0013+0010+0FF8+180C+3006+3000+3000+3000+3000+3006+180C+0FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0188+ENCODING 392+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+000E+0013+0010+1FF8+300C+6000+6000+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0189+ENCODING 393+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+7FE0+1830+1818+180C+180C+7F8C+180C+180C+1818+1830+7FE0+0000+0000+0000+ENDCHAR++STARTCHAR U+018A+ENCODING 394+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FF0+4C18+4C0C+6C06+0C06+0C06+0C06+0C06+0C0C+0C18+3FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+018E+ENCODING 398+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFE+6018+0018+0018+0018+0FF8+0018+0018+0018+6018+3FFE+0000+0000+0000+ENDCHAR++STARTCHAR U+0193+ENCODING 403+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+001C+0026+0020+0FF0+1818+300C+3000+3000+30FF+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+01C3+ENCODING 451+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+03C0+03C0+03C0+03C0+0180+0180+0180+0000+0180+03C0+0180+0000+0000+ENDCHAR++STARTCHAR U+01CD+ENCODING 461+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+01CE+ENCODING 462+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+01CF+ENCODING 463+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+01D0+ENCODING 464+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+01D1+ENCODING 465+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+01D2+ENCODING 466+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+01D3+ENCODING 467+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+01D4+ENCODING 468+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+01DD+ENCODING 477+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0FFC+1806+1803+0FFF+0003+0003+7006+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+01E2+ENCODING 482+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01F0+01F0+0000+1FFC+06C6+04C0+0CC0+0FF8+18C0+18C0+30C0+30C6+79FC+0000+0000+0000+ENDCHAR++STARTCHAR U+01E3+ENCODING 483+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+3E7C+63C6+0186+1FFC+3180+6180+61C6+3E7C+0000+0000+0000+ENDCHAR++STARTCHAR U+01E6+ENCODING 486+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+0FF0+1818+300C+3000+3000+30FF+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+01E7+ENCODING 487+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0360+01C0+0080+0000+0FE7+181C+300C+300C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+01EA+ENCODING 490+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+07E0+0C30+1818+300C+300C+300C+300C+300C+1818+0C30+07E0+0180+0300+01C0+ENDCHAR++STARTCHAR U+01EB+ENCODING 491+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0180+0300+01C0+ENDCHAR++STARTCHAR U+01EC+ENCODING 492+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03E0+03E0+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0180+0300+01C0+ENDCHAR++STARTCHAR U+01ED+ENCODING 493+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0180+0300+01C0+ENDCHAR++STARTCHAR U+01F0+ENCODING 496+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0036+001C+0008+0000+0000+03FC+000C+000C+000C+000C+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+01F4+ENCODING 500+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+0FF0+1818+300C+3000+3000+30FF+300C+300C+1818+0FF0+0000+0000+0000+ENDCHAR++STARTCHAR U+01F5+ENCODING 501+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0060+00C0+0080+0000+0FE7+181C+300C+300C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+01F8+ENCODING 504+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0220+01C0+0000+783F+1C0C+1E0C+1B0C+198C+18CC+186C+183C+181C+7E0C+0000+0000+0000+ENDCHAR++STARTCHAR U+01F9+ENCODING 505+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0220+01C0+0000+0000+73F0+1C18+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+01FC+ENCODING 508+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0060+00C0+0000+1FFC+06C6+04C0+0CC0+0FF8+18C0+18C0+30C0+30C6+79FC+0000+0000+0000+ENDCHAR++STARTCHAR U+01FD+ENCODING 509+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00C0+0180+0100+0000+3E7C+63C6+0186+1FFC+3180+6180+61C6+3E7C+0000+0000+0000+ENDCHAR++STARTCHAR U+01FE+ENCODING 510+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+00C0+0180+0000+07D8+0C30+1868+30CC+318C+330C+360C+1C18+1830+37E0+0000+0000+0000+ENDCHAR++STARTCHAR U+01FF+ENCODING 511+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0060+00C0+0080+0000+0FFA+180E+303C+30E6+3386+1E06+380C+2FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0202+ENCODING 514+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0380+0440+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0203+ENCODING 515+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+01C0+0220+0000+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0206+ENCODING 518+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0220+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+0207+ENCODING 519+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+01C0+0220+0000+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+020A+ENCODING 522+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0380+0440+0000+3FFC+0180+0180+0180+0180+0180+0180+0180+0180+3FFC+0000+0000+0000+ENDCHAR++STARTCHAR U+020B+ENCODING 523+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+01C0+0220+0000+0000+0000+1FC0+00C0+00C0+00C0+00C0+00C0+7FFF+0000+0000+0000+ENDCHAR++STARTCHAR U+020E+ENCODING 526+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0220+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+020F+ENCODING 527+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+01C0+0220+0000+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0212+ENCODING 530+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0220+0000+7FF0+1818+180C+180C+1FF8+18C0+1860+1830+1818+7C3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0213+ENCODING 531+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+00E0+0110+0000+0000+79FC+0E07+0C00+0C00+0C00+0C00+0C00+7F80+0000+0000+0000+ENDCHAR++STARTCHAR U+0216+ENCODING 534+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+01C0+0220+0000+7C1F+180C+180C+180C+180C+180C+180C+180C+0C18+07F0+0000+0000+0000+ENDCHAR++STARTCHAR U+0217+ENCODING 535+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+01C0+0220+0000+0000+783C+180C+180C+180C+180C+180C+181C+0FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0218+ENCODING 536+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0FF8+180C+3000+3000+1800+0FF8+000C+0006+0006+300C+1FF8+0000+0180+0300+ENDCHAR++STARTCHAR U+0219+ENCODING 537+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0FFC+3807+3800+0FF8+000C+0006+7006+1FFC+0000+00C0+0180+ENDCHAR++STARTCHAR U+021A+ENCODING 538+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+3FFC+6186+0180+0180+0180+0180+0180+0180+0180+0180+07E0+0000+0180+0300+ENDCHAR++STARTCHAR U+021B+ENCODING 539+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0600+0600+0600+7FF8+0600+0600+0600+0600+0607+01FC+0000+0060+00C0+ENDCHAR++STARTCHAR U+021E+ENCODING 542+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0360+01C0+0000+7C1F+180C+180C+180C+1FFC+180C+180C+180C+180C+7C1F+0000+0000+0000+ENDCHAR++STARTCHAR U+021F+ENCODING 543+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0D80+0700+0200+7800+1800+1800+1FF8+180C+180C+180C+180C+180C+7E0F+0000+0000+0000+ENDCHAR++STARTCHAR U+0226+ENCODING 550+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0180+0000+0FC0+0360+0220+0630+0410+0FF8+0C18+180C+180C+7E3F+0000+0000+0000+ENDCHAR++STARTCHAR U+0227+ENCODING 551+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0000+1FF8+700C+000C+0FFC+180C+300C+301C+1FE7+0000+0000+0000+ENDCHAR++STARTCHAR U+0228+ENCODING 552+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+7FFC+1806+1800+1800+1FF0+1800+1800+1800+1806+7FFC+00C0+0060+01C0+ENDCHAR++STARTCHAR U+0229+ENCODING 553+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+1FF8+300C+600C+7FF8+6000+6000+3007+1FFC+00C0+0060+01C0+ENDCHAR++STARTCHAR U+022E+ENCODING 558+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0180+0180+0000+07E0+0C30+1818+300C+300C+300C+300C+1818+0C30+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+022F+ENCODING 559+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0000+1FF8+300C+6006+6006+6006+6006+300C+1FF8+0000+0000+0000+ENDCHAR++STARTCHAR U+0232+ENCODING 562+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+03C0+03C0+0000+7C3E+1818+0C30+0660+03C0+0180+0180+0180+0180+07E0+0000+0000+0000+ENDCHAR++STARTCHAR U+0233+ENCODING 563+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+03E0+03E0+0000+783F+180C+180C+180C+180C+0FFC+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+0237+ENCODING 567+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+03FC+000C+000C+000C+000C+000C+700C+1FF8+0000+0000+ENDCHAR++STARTCHAR U+2020+ENCODING 8224+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0180+1FF8+1FF8+0180+0180+0180+0180+0180+0180+0180+0180+0000+ENDCHAR++STARTCHAR U+2021+ENCODING 8225+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0180+0180+0180+1FF8+1FF8+0180+0180+0180+1FF8+1FF8+0180+0180+0180+0000+ENDCHAR++STARTCHAR U+2022+ENCODING 8226+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0180+03C0+03C0+0180+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+2039+ENCODING 8249+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0070+01C0+0700+01C0+0070+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+203A+ENCODING 8250+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0700+01C0+0070+01C0+0700+0000+0000+0000+0000+0000+0000+ENDCHAR++STARTCHAR U+20AC+ENCODING 8364+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+03F8+07FC+0E04+3FC0+3FC0+0C00+0C00+3FC0+3FC0+0E04+07FC+03F8+0000+0000+0000+ENDCHAR++STARTCHAR U+22C5+ENCODING 8901+SWIDTH 1000 0+DWIDTH 16 0+BBX 16 16 0 -3+BITMAP+0000+0000+0000+0000+0000+0000+0000+0000+0180+0000+0000+0000+0000+0000+0000+0000+ENDCHAR++ENDFONT
+ GameDefinition/fonts/16x16xw.woff view

binary file changed (absent → 44768 bytes)

+ GameDefinition/fonts/8x8x.fnt view

binary file changed (absent → 3211 bytes)

+ GameDefinition/fonts/8x8xb.fnt view

binary file changed (absent → 3212 bytes)

+ GameDefinition/fonts/BinaryCodeProLH-Bold.ttf.woff view

binary file changed (absent → 70820 bytes)

+ GameDefinition/fonts/BinarySansProLH-Regular.ttf.woff view

binary file changed (absent → 75896 bytes)

+ GameDefinition/fonts/BinarySansProLH-Semibold.ttf.woff view

binary file changed (absent → 75964 bytes)

+ GameDefinition/fonts/DejaVuLGCSans-Bold.ttf.woff view

binary file changed (absent → 230292 bytes)

+ GameDefinition/fonts/DejaVuLGCSans.ttf.woff view

binary file changed (absent → 244944 bytes)

+ GameDefinition/fonts/Hack-Bold.ttf.woff view

binary file changed (absent → 134196 bytes)

+ GameDefinition/game-src/Client/UI/Content/Input.hs view
@@ -0,0 +1,267 @@+-- | The default game key-command mapping to be used for UI. Can be overridden+-- via macros in the config file.+module Client.UI.Content.Input+  ( standardKeysAndMouse+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , applyTs+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Client.UI.Content.Input+import Game.LambdaHack.Client.UI.HumanCmd+import Game.LambdaHack.Definition.Defs++-- | Description of default key-command bindings.+--+-- In addition to these commands, mouse and keys have a standard meaning+-- when navigating various menus.+standardKeysAndMouse :: InputContentRaw+standardKeysAndMouse = InputContentRaw $ map evalKeyDef $+  -- All commands are defined here, except some movement and leader picking+  -- commands. All commands are shown on help screens except debug commands+  -- and macros with empty descriptions.+  -- The order below determines the order on the help screens.+  -- Remember to put commands that show information (e.g., enter aiming+  -- mode) first.++  -- Minimal command set, in the desired presentation order.+  -- A lot of these are not necessary, but may be familiar to new players.+  -- Also a few non-minimal item commands to keep proper order.+  [ ("I", ( [CmdMinimal, CmdItem, CmdDashboard]+          , "manage the shared inventory stash"+          , ChooseItemMenu (MStore CStash) ))+  , ("O", ( [CmdItem, CmdDashboard]+          , "manage the equipment outfit of the pointman"+          , ChooseItemMenu (MStore CEqp) ))+  , ("g", addCmdCategory CmdMinimal $ grabItems "grab item(s)")+  , ("Escape", ( [CmdMinimal, CmdAim]+               , "clear messages/open main menu/finish aiming"+               , ByAimMode AimModeCmd+                             { exploration = ExecuteIfClear MainMenuAutoOff+                             , aiming = Cancel } ))+  , ("C-Escape", ([], "", MainMenuAutoOn))+      -- required by frontends; not shown+  , ("Return", ( [CmdMinimal, CmdAim]+               , "open dashboard/accept target"+               , ByAimMode AimModeCmd { exploration = Dashboard+                                      , aiming = Accept } ))+  , ("space", ( [CmdMinimal, CmdAim]+              , "clear messages/show history/cycle detail level"+              , ByAimMode AimModeCmd { exploration = ExecuteIfClear AllHistory+                                     , aiming = DetailCycle } ))+  , ("Tab", memberCycle Forward [CmdMinimal, CmdMove])+      -- listed here to keep proper order of the minimal cheat sheet+  , ("BackTab", memberCycle Backward [CmdMove])+  , ("A-Tab", memberCycleLevel Forward [])+  , ("A-BackTab", memberCycleLevel Backward [])+  , ("C-Tab", memberCycleLevel Forward [CmdMove])+  , ("C-BackTab", memberCycleLevel Backward [CmdMove])+  , ("*", ( [CmdMinimal, CmdAim]+          , "cycle crosshair among enemies"+          , AimEnemy ))+  , ("/", ([CmdMinimal, CmdAim], "cycle crosshair among items", AimItem))+  , ("m", ([CmdMove], "modify door by closing it", CloseDir))+  , ("M", ([CmdMinimal, CmdMove], "modify any admissible terrain", AlterDir))+  , ("%", ([CmdMinimal, CmdMeta], "yell or yawn and stop sleeping", Yell))++  -- Item menu, first part of item use commands+  , ("comma", grabItems "")  -- only show extra key, not extra entry+  , ("r", dropItems "remove item(s)")+  , ("f", addCmdCategory CmdItemMenu $ projectA flingTs)+  , ("C-f", addCmdCategory CmdItemMenu+            $ replaceDesc "auto-fling and keep choice"+            $ projectI flingTs)+  , ("t", addCmdCategory CmdItemMenu $ applyI applyTs)+  , ("C-t", addCmdCategory CmdItemMenu+            $ replaceDesc "trigger item and keep choice" $ applyIK applyTs)+  , ("i", replaceDesc "stash item into shared inventory"+          $ moveItemTriple [CGround, CEqp] CStash "item" False)+  , ("o", replaceDesc "equip item into outfit of the pointman"+          $ moveItemTriple [CGround, CStash] CEqp "item" False)++  -- Remaining @ChooseItemMenu@ instances+  , ("G", ( [CmdItem, CmdDashboard]+          , "manage items on the ground"+          , ChooseItemMenu (MStore CGround) ))+  , ("T", ( [CmdItem, CmdDashboard]+          , "manage our total team belongings"+          , ChooseItemMenu MOwned ))+  , ("@", ( [CmdMeta, CmdDashboard]+          , "describe organs of the pointman"+          , ChooseItemMenu (MLore SBody) ))+  , ("#", ( [CmdMeta, CmdDashboard]+          , "show skill summary of the pointman"+          , ChooseItemMenu MSkills ))+  , ("~", ( [CmdMeta]+          , "display relevant lore"+          , ChooseItemMenu (MLore SItem) ))++  -- Dashboard, in addition to commands marked above+  , ("safeD0", ([CmdInternal, CmdDashboard], "", Cancel))  -- blank line+  ]+  +++  zipWith (\k slore -> ("safeD" ++ show (k :: Int)+                       , ( [CmdInternal, CmdDashboard]+                         , "display" <+> ppSLore slore <+> "lore"+                         , ChooseItemMenu (MLore slore) )))+          [1..] [minBound..SEmbed]+  +++  [ ("safeD96", ( [CmdInternal, CmdDashboard]+                , "display place lore"+                , ChooseItemMenu MPlaces) )+  , ("safeD97", ( [CmdInternal, CmdDashboard]+                , "display faction lore"+                , ChooseItemMenu MFactions) )+  , ("safeD98", ( [CmdInternal, CmdDashboard]+                , "display adventure lore"+                , ChooseItemMenu MModes) )+  , ("safeD99", ([CmdInternal, CmdDashboard], "", Cancel))  -- blank line++  -- Terrain exploration and modification+  , ("=", ( [CmdMove], "select (or deselect) party member", SelectActor) )+  , ("_", ([CmdMove], "deselect (or select) all on the level", SelectNone))+  , ("semicolon", ( [CmdMove]+                  , "go to crosshair for 25 steps"+                  , Macro ["C-semicolon", "C-quotedbl", "C-v"] ))+  , ("colon", ( [CmdMove]+              , "run to crosshair collectively for 25 steps"+              , Macro ["C-colon", "C-quotedbl", "C-v"] ))+  , ("[", ( [CmdMove]+          , "explore nearest unknown spot"+          , autoexploreCmd ))+  , ("]", ( [CmdMove]+          , "autoexplore 25 times"+          , autoexplore25Cmd ))+  , ("R", ([CmdMove], "rest (wait 25 times)", Macro ["KP_Begin", "C-v"]))+  , ("C-R", ( [CmdMove], "heed (lurk 0.1 turns 100 times)"+            , Macro ["C-KP_Begin", "A-v"] ))++  -- Aiming+  , ("+", ([CmdAim], "swerve the aiming line", EpsIncr Forward))+  , ("-", ([CmdAim], "unswerve the aiming line", EpsIncr Backward))+  , ("\\", ([CmdAim], "cycle aiming modes", AimFloor))+  , ("C-?", ( [CmdAim]+            , "set crosshair to nearest unknown spot"+            , XhairUnknown ))+  , ("C-/", ( [CmdAim]+            , "set crosshair to nearest item"+            , XhairItem ))+  , ("C-{", ( [CmdAim]+            , "aim at nearest upstairs"+            , XhairStair True ))+  , ("C-}", ( [CmdAim]+            , "aim at nearest downstairs"+            , XhairStair False ))+  , ("<", ([CmdAim], "move aiming one level up" , AimAscend 1))+  , ("C-<", ([], "move aiming 10 levels up", AimAscend 10))+  , (">", ([CmdAim], "move aiming one level down", AimAscend (-1)))+      -- 'lower' would be misleading in some games, just as 'deeper'+  , ("C->", ([], "move aiming 10 levels down", AimAscend (-10)))+  , ("BackSpace" , ( [CmdAim]+                   , "clear chosen item and crosshair"+                   , ComposeUnlessError ClearTargetIfItemClear ItemClear))++  -- Assorted (first few cloned from main menu)+  , ("C-g", ([CmdMeta], "start new game", GameRestart))+  , ("C-x", ([CmdMeta], "save and exit to desktop", GameExit))+  , ("C-q", ([CmdMeta], "quit game and start autoplay", GameQuit))+  , ("C-c", ([CmdMeta], "exit to desktop without saving", GameDrop))+  , ("?", ([CmdMeta], "display help", Hint))+  , ("F1", ([CmdMeta, CmdDashboard], "display help immediately", Help))+  , ("F12", ([CmdMeta, CmdDashboard], "show history", AllHistory))+  , ("v", repeatLastTriple 1 [CmdMeta])+  , ("C-v", repeatLastTriple 25 [])+  , ("A-v", repeatLastTriple 100 [])+  , ("V", repeatTriple 1 [CmdMeta])+  , ("C-V", repeatTriple 25 [])+  , ("A-V", repeatTriple 100 [])+  , ("'", ([CmdMeta], "start recording commands", Record))+  , ("C-S", ([CmdMeta], "save game backup", GameSave))+  , ("C-P", ([CmdMeta], "print screen", PrintScreen))++  -- Mouse+  , ( "LeftButtonRelease"+    , mouseLMB goToCmd+               "go to pointer for 25 steps/fling at enemy" )+  , ( "S-LeftButtonRelease"+    , mouseLMB runToAllCmd+               "run to pointer collectively for 25 steps/fling at enemy" )+  , ("RightButtonRelease", mouseRMB)+  , ("C-LeftButtonRelease", replaceDesc "" mouseRMB)  -- Mac convention+  , ( "S-RightButtonRelease"+    , ([CmdMouse], "modify terrain at pointer", AlterWithPointer) )+  , ("MiddleButtonRelease", mouseMMB)+  , ("C-RightButtonRelease", replaceDesc "" mouseMMB)+  , ( "C-S-LeftButtonRelease", let (_, _, cmd) = mouseMMB+                               in ([], "", cmd) )+  , ("A-MiddleButtonRelease", mouseMMBMute)+  , ("WheelNorth", ([CmdMouse], "swerve the aiming line", Macro ["+"]))+  , ("WheelSouth", ([CmdMouse], "unswerve the aiming line", Macro ["-"]))++  -- Debug and others not to display in help screens+  , ("Escape", ([CmdMeta], "", AutomateBack))+  , ("Escape", ([CmdMeta], "", MainMenu))+  , ("C-semicolon", ( []+                    , "move one step towards the crosshair"+                    , MoveOnceToXhair ))+  , ("C-colon", ( []+                , "run collectively one step towards the crosshair"+                , RunOnceToXhair ))+  , ("C-quotedbl", ( []+                   , "continue towards the crosshair"+                   , ContinueToXhair ))+  , ("C-comma", ([], "run once ahead", RunOnceAhead))+  , ("safe1", ( [CmdInternal]+              , "go to pointer for 25 steps"+              , goToCmd ))+  , ("safe2", ( [CmdInternal]+              , "run to pointer collectively"+              , runToAllCmd ))+  , ("safe3", ( [CmdInternal]+              , "pick new pointman on screen"+              , PickLeaderWithPointer ))+  , ("safe4", ( [CmdInternal]+              , "select party member on screen"+              , SelectWithPointer ))+  , ("safe5", ( [CmdInternal]+              , "set crosshair to enemy"+              , AimPointerEnemy ))+  , ("safe6", ( [CmdInternal]+              , "fling at enemy under pointer"+              , aimFlingCmd ))+  , ("safe7", ( [CmdInternal, CmdDashboard]+              , "open main menu"+              , MainMenuAutoOff ))+  , ("safe8", ( [CmdInternal]+              , "clear msgs and open main menu"+              , ExecuteIfClear MainMenuAutoOff ))+  , ("safe9", ( [CmdInternal]+              , "cancel aiming"+              , Cancel ))+  , ("safe10", ( [CmdInternal]+               , "accept target"+               , Accept ))+  , ("safe11", ( [CmdInternal]+               , "wait a turn, bracing for impact"+               , Wait ))+  , ("safe12", ( [CmdInternal]+               , "lurk 0.1 of a turn"+               , Wait10 ))+  , ("safe13", ( [CmdInternal]+               , "snap crosshair to enemy"+               , XhairPointerEnemy ))+  , ("safe14", ( [CmdInternal]+               , "open dashboard"+               , Dashboard ))+  ]+  ++ map defaultHeroSelect [0..9]++applyTs :: [TriggerItem]+applyTs = [TriggerItem { tiverb = "trigger"+                       , tiobject = "consumable item"+                       , tisymbols = "!,?/" }]
+ GameDefinition/game-src/Client/UI/Content/Screen.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell #-}+-- | The default screen layout and features definition.+module Client.UI.Content.Screen+  ( standardLayoutAndFeatures+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import           Data.FileEmbed (embedDir)+import           Language.Haskell.TH.Syntax+import           System.IO++import Game.LambdaHack.Client.UI.Content.Screen++-- | Description of default screen layout and features.+standardLayoutAndFeatures :: ScreenContent+standardLayoutAndFeatures = ScreenContent+  { rwidth = 80+  , rheight = 24+  , rwebAddress = "http://lambdahack.github.io"+  , rintroScreen = $(do+      let path = "GameDefinition/PLAYING.md"+      qAddDependentFile path+      x <- qRunIO $ do+        handle <- openFile path ReadMode+        hSetEncoding handle utf8+        hGetContents handle+      let paragraphs :: [String] -> [String] -> [[String]]+          paragraphs [] rows = [reverse rows]+          paragraphs (l@"" : ls) rows = case (rows, ls) of+            (('=':'=' : _) : _, _) ->  -- A title. No new paragraph.+              paragraphs ls (l : rows)+            (('-':'-' : _) : _, _) ->  -- A title. No new paragraph.+              paragraphs ls (l : rows)+            ((' ':' ':' ':' ' : _) : _, (' ':' ':' ':' ' : _) : _) ->+              -- At least four spaces before and after; probably a code block.+              paragraphs ls (l : rows)+            _ -> reverse rows : paragraphs ls []+          paragraphs (l : ls) rows = paragraphs ls (l : rows)+          intro = case paragraphs (lines x) [] of+            _titleAndBlurb : par1 : par2 : rest ->+              (par1 ++ [""] ++ par2, rest)+            _ -> error "not enough paragraphs in intro screen text"+      lift intro)+  , rapplyVerbMap = EM.fromList [('!', "quaff"), (',', "eat"), ('?', "read")]+  , rFontFiles =+#ifdef USE_BROWSER+      []+#else+      $(embedDir "GameDefinition/fonts")+#endif+  }
+ GameDefinition/game-src/Implementation/MonadClientImplementation.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | The implementation of our custom game client monads. Just as any other+-- component of the library, this implementation can be substituted.+module Implementation.MonadClientImplementation+  ( executorCli+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , CliState(..), CliImplementation(..)+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import qualified Control.Monad.IO.Class as IO+import           Control.Monad.Trans.State.Strict hiding (State)++import           Game.LambdaHack.Atomic (MonadStateWrite (..))+import           Game.LambdaHack.Client+import qualified Game.LambdaHack.Client.BfsM as BfsM+import           Game.LambdaHack.Client.HandleAtomicM+import           Game.LambdaHack.Client.HandleResponseM+import           Game.LambdaHack.Client.LoopM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.MonadStateRead+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Server (ChanServer (..))++data CliState = CliState+  { cliState   :: State            -- ^ current global state+  , cliClient  :: StateClient      -- ^ current client state+  , cliSession :: Maybe SessionUI  -- ^ UI state, empty for AI clients+  , cliDict    :: ChanServer       -- ^ this client connection information+  , cliToSave  :: Save.ChanSave (StateClient, Maybe SessionUI)+                                   -- ^ connection to the save thread+  }++-- | Client state transformation monad.+newtype CliImplementation a = CliImplementation+  { runCliImplementation :: StateT CliState IO a }+  deriving (Monad, Functor, Applicative)++instance MonadStateRead CliImplementation where+  {-# INLINE getsState #-}+  getsState f = CliImplementation $ gets $ f . cliState++instance MonadStateWrite CliImplementation where+  {-# INLINE modifyState #-}+  modifyState f = CliImplementation $ state $ \cliS ->+    let !newCliS = cliS {cliState = f $ cliState cliS}+    in ((), newCliS)+  {-# INLINE putState #-}+  putState newCliState = CliImplementation $ state $ \cliS ->+    let !newCliS = cliS {cliState = newCliState}+    in ((), newCliS)++instance MonadClientRead CliImplementation where+  {-# INLINE getsClient #-}+  getsClient f = CliImplementation $ gets $ f . cliClient+  liftIO = CliImplementation . IO.liftIO++instance MonadClient CliImplementation where+  {-# INLINE modifyClient #-}+  modifyClient f = CliImplementation $ state $ \cliS ->+    let !newCliS = cliS {cliClient = f $ cliClient cliS}+    in ((), newCliS)++instance MonadClientSetup CliImplementation where+  saveClient = CliImplementation $ do+    toSave <- gets cliToSave+    cli <- gets cliClient+    msess <- gets cliSession+    IO.liftIO $ Save.saveToChan toSave (cli, msess)++instance MonadClientUI CliImplementation where+  {-# INLINE getsSession #-}+  getsSession f = CliImplementation $ gets $ f . fromJust . cliSession+  {-# INLINE modifySession #-}+  modifySession f = CliImplementation $ state $ \cliS ->+    let !newCliSession = f $ fromJust $ cliSession cliS+        !newCliS = cliS {cliSession = Just newCliSession}+    in ((), newCliS)+  updateClientLeader aid = do+    s <- getState+    modifyClient $ updateLeader aid s+  getCacheBfs = BfsM.getCacheBfs+  getCachePath = BfsM.getCachePath++instance MonadClientReadResponse CliImplementation where+  receiveResponse = CliImplementation $ do+    ChanServer{responseS} <- gets cliDict+    IO.liftIO $ takeMVar responseS++instance MonadClientWriteRequest CliImplementation where+  sendRequestAI scmd = CliImplementation $ do+    ChanServer{requestAIS} <- gets cliDict+    IO.liftIO $ putMVar requestAIS scmd+  sendRequestUI scmd = CliImplementation $ do+    ChanServer{requestUIS} <- gets cliDict+    IO.liftIO $ putMVar (fromJust requestUIS) scmd+  clientHasUI = CliImplementation $ do+    mSession <- gets cliSession+    return $! isJust mSession++instance MonadClientAtomic CliImplementation where+  {-# INLINE execUpdAtomic #-}+  execUpdAtomic _ = return ()  -- handleUpdAtomic, until needed, save resources+    -- Don't catch anything; assume exceptions impossible.+  {-# INLINE execPutState #-}+  execPutState = putState++-- | Run the main client loop, with the given arguments and empty+-- initial states, in the @IO@ monad.+executorCli :: CCUI -> UIOptions -> ClientOptions -> Bool+            -> COps+            -> FactionId+            -> ChanServer+            -> IO ()+executorCli ccui sUIOptions clientOptions startsNewGame+            cops@COps{corule} fid cliDict =+  let cliSession | isJust (requestUIS cliDict) =+                     Just $ emptySessionUI sUIOptions+                 | otherwise = Nothing+      stateToFileName (cli, _) =+        ssavePrefixCli (soptions cli) <> Save.saveNameCli corule (sside cli)+      totalState cliToSave = CliState+        { cliState = updateCOpsAndCachedData (const cops) emptyState+            -- state is empty, so the cached data is left empty and untouched+        , cliClient = emptyStateClient fid+        , cliDict+        , cliToSave+        , cliSession+        }+      m = loopCli ccui sUIOptions clientOptions startsNewGame+      exe = evalStateT (runCliImplementation m) . totalState+  in Save.wrapInSaves cops stateToFileName exe
+ GameDefinition/game-src/Implementation/MonadServerImplementation.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | The implementation of our custom game server monads. Just as any other+-- component of the library, this implementation can be substituted.+module Implementation.MonadServerImplementation+  ( executorSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , SerState(..), SerImplementation(..)+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import           Control.Concurrent.Async+import qualified Control.Exception as Ex+import qualified Control.Monad.IO.Class as IO+import           Control.Monad.Trans.State.Strict hiding (State)+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text.IO as T+import           Options.Applicative+  (defaultPrefs, execParserPure, handleParseResult)+import           System.Exit (ExitCode)+import           System.IO (hFlush, stdout)++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.MonadStateRead+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Thread+import           Game.LambdaHack.Server+import           Game.LambdaHack.Server.BroadcastAtomic+import           Game.LambdaHack.Server.HandleAtomicM+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.ProtocolM+import           Game.LambdaHack.Server.State++import Implementation.MonadClientImplementation (executorCli)++data SerState = SerState+  { serState  :: State             -- ^ current global state+  , serServer :: StateServer       -- ^ current server state+  , serDict   :: ConnServerDict    -- ^ client-server connection information+  , serToSave :: Save.ChanSave (State, StateServer)+                                       -- ^ connection to the save thread+  }++-- | Server state transformation monad.+newtype SerImplementation a =+    SerImplementation {runSerImplementation :: StateT SerState IO a}+  deriving (Monad, Functor, Applicative)++instance MonadStateRead SerImplementation where+  {-# INLINE getsState #-}+  getsState f = SerImplementation $ gets $ f . serState++instance MonadStateWrite SerImplementation where+  {-# INLINE modifyState #-}+  modifyState f = SerImplementation $ state $ \serS ->+    let !newSerS = serS {serState = f $ serState serS}+    in ((), newSerS)+  {-# INLINE putState #-}+  putState newSerState = SerImplementation $ state $ \serS ->+    let !newSerS = serS {serState = newSerState}+    in ((), newSerS)++instance MonadServer SerImplementation where+  {-# INLINE getsServer #-}+  getsServer   f = SerImplementation $ gets $ f . serServer+  {-# INLINE modifyServer #-}+  modifyServer f = SerImplementation $ state $ \serS ->+    let !newSerS = serS {serServer = f $ serServer serS}+    in ((), newSerS)+  chanSaveServer = SerImplementation $ gets serToSave+  liftIO         = SerImplementation . IO.liftIO++instance MonadServerComm SerImplementation where+  {-# INLINE getsDict #-}+  getsDict f = SerImplementation $ gets $ f . serDict+  {-# INLINE putDict #-}+  putDict newSerDict = SerImplementation $ state $ \serS ->+    let !newSerS = serS {serDict = newSerDict}+    in ((), newSerS)+  liftIO = SerImplementation . IO.liftIO++instance MonadServerAtomic SerImplementation where+  execUpdAtomic cmd = do+    oldState <- getState+    (ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd+    when executedOnServer $ cmdAtomicSemSer oldState cmd+    handleAndBroadcast ps atomicBroken (UpdAtomic cmd)+  execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do+    cliSNewOrE <- Ex.try+                  $ execStateT (runSerImplementation $ handleUpdAtomic cmd)+                               cliS+    case cliSNewOrE of+      Left AtomicFail{} -> return (False, cliS)+      Right !cliSNew ->+        -- We know @cliSNew@ differs only in @serState@.+        return (True, cliSNew)+  execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do+    -- Don't catch anything; assume exceptions impossible.+    let sFid = sclientStates (serServer cliS) EM.! fid+    cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd)+                          cliS {serState = sFid}+    -- We know @cliSNew@ differs only in @serState@.+    let serServerNew = (serServer cliS)+          {sclientStates = EM.insert fid (serState cliSNew)+                           $ sclientStates $ serServer cliS}+        !newCliS = cliS {serServer = serServerNew}+    return ((), newCliS)+  execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do+    let sFid = sclientStates (serServer cliS) EM.! fid+    cliSNewOrE <- Ex.try+                  $ execStateT (runSerImplementation $ handleUpdAtomic cmd)+                               cliS {serState = sFid}+    case cliSNewOrE of+      Left AtomicFail{} -> return (False, cliS)+      Right cliSNew -> do+        -- We know @cliSNew@ differs only in @serState@.+        let serServerNew = (serServer cliS)+              {sclientStates = EM.insert fid (serState cliSNew)+                               $ sclientStates $ serServer cliS}+            !newCliS = cliS {serServer = serServerNew}+        return (True, newCliS)+  execSfxAtomic sfx = do+    ps <- posSfxAtomic sfx+    handleAndBroadcast ps [] (SfxAtomic sfx)+  execSendPer = sendPer++-- Don't inline this, to keep GHC hard work inside the library+-- for easy access of code analysis tools.+-- | Run the main server loop, with the given arguments and empty+-- initial states, in the @IO@ monad.+executorSer :: COps -> CCUI -> ServerOptions -> UIOptions -> IO ()+executorSer cops@COps{corule} ccui soptionsNxtCmdline sUIOptions = do+  soptionsNxtRaw <- case uOverrideCmdline sUIOptions of+    []   -> return soptionsNxtCmdline+    args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args+  -- Options for the clients modified with the configuration file.+  let clientOptions = applyUIOptions cops sUIOptions+                      $ sclientOptions soptionsNxtRaw+      soptionsNxt = soptionsNxtRaw {sclientOptions = clientOptions}+      -- Partially applied main loop of the clients.+      executorClient startsNewGame =+        executorCli ccui sUIOptions clientOptions startsNewGame cops+  -- Wire together game content, the main loop of game clients+  -- and the game server loop.+  let stateToFileName (_, ser) =+        ssavePrefixSer (soptions ser) <> Save.saveNameSer corule+      totalState serToSave = SerState+        { serState = updateCOpsAndCachedData (const cops) emptyState+            -- state is empty, so the cached data is left empty and untouched+        , serServer = emptyStateServer+        , serDict = EM.empty+        , serToSave+        }+      m = loopSer soptionsNxt executorClient+      exe = evalStateT (runSerImplementation m) . totalState+      exeWithSaves = Save.wrapInSaves cops stateToFileName exe+      unwrapEx e = case Ex.fromException e of+        Just (ExceptionInLinkedThread _ ex) -> unwrapEx ex+        _ -> e+  -- Wait for clients to exit even in case of server crash+  -- (or server and client crash), which gives them time to save+  -- and report their own inconsistencies, if any.+  Ex.handle (\ex -> case Ex.fromException (unwrapEx ex) :: Maybe ExitCode of+               Just{} ->+                 -- User-forced shutdown, not crash, so the intention is+                 -- to keep old saves and also clients may be not ready to save.+                 Ex.throwIO ex+               _ -> do+                 Ex.uninterruptibleMask_ $ threadDelay 1000000+                   -- let clients report their errors and save+                 moveAside <- Save.bkpAllSaves corule clientOptions+                 when moveAside $+                   T.hPutStrLn stdout+                               "The game crashed, so savefiles are moved aside."+                 hFlush stdout+                 Ex.throwIO ex  -- crash eventually, which kills clients+            )+            exeWithSaves+--  T.hPutStrLn stdout "Server exiting, waiting for clients."+--  hFlush stdout+  waitForChildren childrenServer  -- no crash, wait for clients indefinitely+--  T.hPutStrLn stdout "Server exiting now."+--  hFlush stdout
+ GameDefinition/game-src/TieKnot.hs view
@@ -0,0 +1,161 @@+-- | Here the knot of engine code pieces, frontend and the game-specific+-- content definitions is tied, resulting in an executable game.+module TieKnot+  ( tieKnotForAsync, tieKnot+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import           Control.Concurrent.Async+import qualified Control.Exception as Ex+import qualified Data.Primitive.PrimArray as PA+import           GHC.Compact+import qualified System.Random.SplitMix32 as SM++import           Game.LambdaHack.Client+import qualified Game.LambdaHack.Client.UI.Content.Input as IC+import qualified Game.LambdaHack.Client.UI.Content.Screen as SC+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Point (speedupHackXSize)+import qualified Game.LambdaHack.Common.Tile as Tile+import qualified Game.LambdaHack.Content.CaveKind as CK+import qualified Game.LambdaHack.Content.FactionKind as FK+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.ModeKind as MK+import qualified Game.LambdaHack.Content.PlaceKind as PK+import qualified Game.LambdaHack.Content.RuleKind as RK+import qualified Game.LambdaHack.Content.TileKind as TK+import           Game.LambdaHack.Server++import qualified Client.UI.Content.Input as Content.Input+import qualified Client.UI.Content.Screen as Content.Screen+import qualified Content.CaveKind+import qualified Content.FactionKind+import qualified Content.ItemKind+import qualified Content.ModeKind+import qualified Content.PlaceKind+import qualified Content.RuleKind+import qualified Content.TileKind+import           Implementation.MonadServerImplementation (executorSer)++-- | Tie the LambdaHack engine client, server and frontend code+-- with the game-specific content definitions, and run the game.+--+-- The custom monad types to be used are determined by the @executorSer@+-- call, which in turn calls @executorCli@. If other functions are used+-- in their place- the types are different and so the whole pattern+-- of computation differs. Which of the frontends is run inside the UI client+-- depends on the flags supplied when compiling the engine library.+-- Similarly for the choice of native vs JS builds.+tieKnotForAsync :: ServerOptions -> IO ()+tieKnotForAsync options@ServerOptions{ sallClear+                                     , sboostRandomItem+                                     , sdungeonRng } = do+  -- Set the X size of the dungeon from content ASAP, before it's used.+  speedupHackXSizeThawed <- PA.unsafeThawPrimArray speedupHackXSize+  PA.writePrimArray speedupHackXSizeThawed 0 $+    RK.rWidthMax Content.RuleKind.standardRules+  void $ PA.unsafeFreezePrimArray speedupHackXSizeThawed+  -- This setup ensures the boosting option doesn't affect generating initial+  -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline+  -- equal to what was generated last time, ensures the same item boost.+  initialGen <- maybe SM.newSMGen return sdungeonRng+  let soptionsNxt = options {sdungeonRng = Just initialGen}+      corule = RK.makeData Content.RuleKind.standardRules+      boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items+      itemContent =+        if sboostRandomItem+        then boostedItems ++ Content.ItemKind.otherItemContent+        else Content.ItemKind.content+      coitem = IK.makeData (RK.ritemSymbols corule)+                           itemContent+                           Content.ItemKind.groupNamesSingleton+                           Content.ItemKind.groupNames+      cotile = TK.makeData Content.TileKind.content+                           Content.TileKind.groupNamesSingleton+                           Content.TileKind.groupNames+      cofact = FK.makeData Content.FactionKind.content+                           Content.FactionKind.groupNamesSingleton+                           Content.FactionKind.groupNames+      -- Common content operations, created from content definitions.+      -- Evaluated fully to discover errors ASAP and to free memory.+      -- Fail here, not inside server code, so that savefiles are not removed,+      -- because they are not the source of the failure.+      copsRaw = COps+        { cocave = CK.makeData corule+                               Content.CaveKind.content+                               Content.CaveKind.groupNamesSingleton+                               Content.CaveKind.groupNames+        , cofact+        , coitem+        , comode = MK.makeData cofact+                               Content.ModeKind.content+                               Content.ModeKind.groupNamesSingleton+                               Content.ModeKind.groupNames+        , coplace = PK.makeData cotile+                                Content.PlaceKind.content+                                Content.PlaceKind.groupNamesSingleton+                                Content.PlaceKind.groupNames+        , corule+        , cotile+        , coItemSpeedup = speedupItem coitem+        , coTileSpeedup = Tile.speedupTile sallClear cotile+        }+  -- Evaluating for compact regions catches all kinds of errors in content ASAP,+  -- even in unused items.+  --+  -- Not using @compactWithSharing@, because it helps with residency,+  -- but nothing else and costs a bit at startup.+#ifdef USE_JSFILE+  let cops = copsRaw  -- until GHCJS implements GHC.Compact+#else+  cops <- getCompact <$> compact copsRaw+#endif+  -- Parse UI client configuration file.+  -- It is reparsed at each start of the game executable.+  -- Fail here, not inside client code, so that savefiles are not removed,+  -- because they are not the source of the failure.+  sUIOptions <- mkUIOptions corule (sclientOptions soptionsNxt)+  -- Client content operations containing default keypresses+  -- and command descriptions.+  let !ccui = CCUI+        { coinput = IC.makeData (Just sUIOptions)+                                Content.Input.standardKeysAndMouse+        , coscreen = SC.makeData corule Content.Screen.standardLayoutAndFeatures+        }+  -- Wire together game content, the main loops of game clients+  -- and the game server loop.+  executorSer cops ccui soptionsNxt sUIOptions++-- | Runs tieKnotForAsync in an async and applies the main thread workaround.+tieKnot :: ServerOptions -> IO ()+tieKnot serverOptions = do+#ifdef USE_JSFILE+  -- Hard to tweak the config file when in the browser, so hardwire.+  let serverOptionsJS = serverOptions {sdumpInitRngs = True}+  a <- async $ tieKnotForAsync serverOptionsJS+  wait a+#else+  let fillWorkaround =+        -- Set up void workaround if nothing specific required.+        void $ tryPutMVar workaroundOnMainThreadMVar $ return ()+  -- Avoid the bound thread that would slow down the communication.+  a <- async $ tieKnotForAsync serverOptions+               `Ex.finally` fillWorkaround+  -- Exit on an exception without waiting for frontend to spawn.+  link a+  -- Run a (possibly void) workaround. It's needed for OSes/frontends+  -- that need to perform some actions on the main thread+  -- (not just any bound thread), e.g., newer OS X drawing with SDL2.+  join (takeMVar workaroundOnMainThreadMVar)+  -- Wait in case frontend workaround not run on the main thread+  -- and so we'd exit too early and end the game.+  wait a+  -- Consume the void workaround if it was spurious to make @tieKnot@ reentrant.+  void $ tryTakeMVar workaroundOnMainThreadMVar+#endif
− GameDefinition/scores

binary file changed (701 → absent bytes)

− GameDefinition/screenshot.png

binary file changed (13391 → absent bytes)

LICENSE view
@@ -1,28 +1,26 @@-Copyright (c) 2008--2014 Andres Loeh-Copyright (c) 2010--2014 Mikolaj Konarski+BSD 3-Clause License  All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-1. Redistributions of source code must retain the above copyright-   notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-   notice, this list of conditions and the following disclaimer in the-   documentation and/or other materials provided with the distribution.-3. Neither the name of the author nor the names of his contributors-   may be used to endorse or promote products derived from this software-   without specific prior written permission.+1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.+3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE-ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS-OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)-HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF-SUCH DAMAGE.+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
LambdaHack.cabal view
@@ -1,344 +1,397 @@+cabal-version: 2.4 name:          LambdaHack-version:       0.2.14-synopsis:      A roguelike game engine in early development-description:   This is an alpha release of LambdaHack,-               a game engine library for roguelike games-               of arbitrary theme, size and complexity,-               packaged together with a small example dungeon crawler.-               .-               <<GameDefinition/screenshot.png>>-               .-               When completed, the engine will let you specify content-               to be procedurally generated, define the AI behaviour-               on top of the generic content-independent rules-               and compile a ready-to-play game binary, using either-               the supplied or a custom-made main loop.-               Several frontends are available (GTK is the default)-               and many other generic engine components are easily overridden,-               but the fundamental source of flexibility lies-               in the strict and type-safe separation of code and content-               and of clients (human and AI-controlled) and server.-               Please see the changelog file for recent improvements-               and the issue tracker for short-term plans. Long term vision-               revolves around procedural content generation and includes-               in-game content creation, auto-balancing and persistent-               content modification based on player behaviour.-               .-               A larger game that depends on the LambdaHack library-               is Allure of the Stars, available from-               <http://hackage.haskell.org/package/Allure>.-               .-               Note: All modules in this library are kept visible,-               to let games override and reuse them.-               OTOH, to reflect that some modules are implementation details-               relative to others, the source code adheres to the following-               convention. If a module has the same name as a directory,-               the module is the exclusive interface to the directory.-               No references to the modules in the directory are allowed-               except from the interface module. This policy is only binding-               inside the library --- users are free to do whatever they-               please, since the library authors are in no position to guess-               their particular needs.-homepage:      http://github.com/LambdaHack/LambdaHack+-- The package version. See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:+-+------- breaking API changes+--             | |  +----- minor or non-breaking API additions+--             | |  | +--- code changes with no API change+version:       0.11.0.1+synopsis:      A game engine library for tactical squad ASCII roguelike dungeon crawlers+description: LambdaHack is a Haskell game engine library for ASCII roguelike+             games of arbitrary theme, size and complexity, with optional+             tactical squad combat. It's packaged together with a sample+             dungeon crawler in a quirky fantasy setting. The sample game can be+             tried out in the browser at <http://lambdahack.github.io>.+             .+             Please see the changelog file for recent improvements+             and the issue tracker for short-term plans. Long term goals+             include multiplayer tactical squad combat, in-game content+             creation, auto-balancing and persistent content modification+             based on player behaviour. Contributions are welcome.+             .+             Other games known to use the LambdaHack library:+             .+             * Allure of the Stars, a near-future Sci-Fi game,+             <http://hackage.haskell.org/package/Allure>+             .+             Note: All modules in this library are kept visible,+             to let games override and reuse them.+             OTOH, to reflect that some modules are implementation details+             relative to others, the source code adheres to the following+             convention. If a module has the same name as a directory,+             the module is the exclusive interface to the directory.+             No references to the modules in the directory are allowed+             except from the interface module. This policy is only binding+             when developing the library --- library users are free+             to access any modules, since the library authors are in+             no position to guess their particular needs.+             .+             This is a workaround .cabal file, flattened to eliminate+             internal libraries until generating haddocks for them+             is fixed. The original .cabal file is in .cabal.bkp file.+homepage:      https://lambdahack.github.io bug-reports:   http://github.com/LambdaHack/LambdaHack/issues-license:       BSD3-license-file:  LICENSE-tested-with:   GHC == 7.6.3, GHC == 7.8-data-files:    GameDefinition/config.ui.default,-               GameDefinition/scores-extra-source-files: GameDefinition/PLAYING.md, GameDefinition/MainMenu.ascii,-                    README.md, LICENSE, CREDITS, CHANGELOG.md, Makefile-extra-doc-files: GameDefinition/screenshot.png-author:        Andres Loeh, Mikolaj Konarski+license:       BSD-3-Clause+license-file:  COPYLEFT+tested-with:   GHC==8.10.*, GHC==9.0.*, GHC==9.2.*, GHC==9.4.*+-- Enough files is included in the Hackage package to run CI and manual+-- tests off it, to be presentable on Hackage and to create user-friendly+-- binary packages.+extra-source-files: GameDefinition/config.ui.default,+                    GameDefinition/PLAYING.md,+                    GameDefinition/fonts/16x16xw.woff,+                    GameDefinition/fonts/16x16xw.bdf,+                    GameDefinition/fonts/16x16x.fnt,+                    GameDefinition/fonts/8x8xb.fnt,+                    GameDefinition/fonts/8x8x.fnt,+                    GameDefinition/fonts/BinarySansProLH-Regular.ttf.woff,+                    GameDefinition/fonts/BinarySansProLH-Semibold.ttf.woff,+                    GameDefinition/fonts/BinaryCodeProLH-Bold.ttf.woff,+                    GameDefinition/fonts/DejaVuLGCSans.ttf.woff,+                    GameDefinition/fonts/DejaVuLGCSans-Bold.ttf.woff,+                    GameDefinition/fonts/Hack-Bold.ttf.woff+extra-doc-files:    GameDefinition/InGameHelp.txt,+                    README.md,+                    CHANGELOG.md,+                    LICENSE,+                    COPYLEFT,+                    CREDITS,+                    cabal.project,+                    Makefile+author:        Andres Loeh, Mikolaj Konarski and others maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com> category:      Game Engine, Game build-type:    Simple-cabal-version: >= 1.10  source-repository head   type:               git   location:           git://github.com/LambdaHack/LambdaHack.git -flag vty-  description:        switch to the vty frontend+flag with_expensive_assertions+  description:        turn on expensive assertions of well-tested code   default:            False+  manual:             True -flag curses-  description:        switch to the curses frontend (not fully supported)-  default:            False+flag release+  description:        prepare for a release (expose internal functions and types, etc.)+  default:            True+  manual:             True -library-  exposed-modules:    Game.LambdaHack.Atomic-                      Game.LambdaHack.Atomic.CmdAtomic,-                      Game.LambdaHack.Atomic.BroadcastAtomicWrite,-                      Game.LambdaHack.Atomic.HandleAtomicWrite,-                      Game.LambdaHack.Atomic.MonadAtomic,-                      Game.LambdaHack.Atomic.MonadStateWrite,-                      Game.LambdaHack.Atomic.PosAtomicRead,-                      Game.LambdaHack.Client,-                      Game.LambdaHack.Client.AI-                      Game.LambdaHack.Client.AI.ConditionClient,-                      Game.LambdaHack.Client.AI.HandleAbilityClient,-                      Game.LambdaHack.Client.AI.PickActorClient-                      Game.LambdaHack.Client.AI.PickTargetClient-                      Game.LambdaHack.Client.AI.Preferences-                      Game.LambdaHack.Client.AI.Strategy,-                      Game.LambdaHack.Client.Bfs,-                      Game.LambdaHack.Client.BfsClient,-                      Game.LambdaHack.Client.CommonClient,-                      Game.LambdaHack.Client.HandleAtomicClient,-                      Game.LambdaHack.Client.HandleResponseClient,-                      Game.LambdaHack.Client.ItemSlot,-                      Game.LambdaHack.Client.Key,-                      Game.LambdaHack.Client.LoopClient,-                      Game.LambdaHack.Client.MonadClient,-                      Game.LambdaHack.Client.ProtocolClient,-                      Game.LambdaHack.Client.State,-                      Game.LambdaHack.Client.UI,-                      Game.LambdaHack.Client.UI.Animation,-                      Game.LambdaHack.Client.UI.Config,-                      Game.LambdaHack.Client.UI.Content.KeyKind-                      Game.LambdaHack.Client.UI.DrawClient,-                      Game.LambdaHack.Client.UI.DisplayAtomicClient,-                      Game.LambdaHack.Client.UI.Frontend,-                      Game.LambdaHack.Client.UI.Frontend.Chosen,-                      Game.LambdaHack.Client.UI.Frontend.Std,-                      Game.LambdaHack.Client.UI.HandleHumanGlobalClient,-                      Game.LambdaHack.Client.UI.HandleHumanLocalClient,-                      Game.LambdaHack.Client.UI.HandleHumanClient,-                      Game.LambdaHack.Client.UI.HumanCmd,-                      Game.LambdaHack.Client.UI.InventoryClient,-                      Game.LambdaHack.Client.UI.KeyBindings,-                      Game.LambdaHack.Client.UI.MonadClientUI,-                      Game.LambdaHack.Client.UI.MsgClient,-                      Game.LambdaHack.Client.UI.RunClient,-                      Game.LambdaHack.Client.UI.StartupFrontendClient-                      Game.LambdaHack.Client.UI.WidgetClient,-                      Game.LambdaHack.Common.Ability,-                      Game.LambdaHack.Common.Actor,-                      Game.LambdaHack.Common.ActorState,-                      Game.LambdaHack.Common.ClientOptions,-                      Game.LambdaHack.Common.Color,-                      Game.LambdaHack.Common.ContentDef,-                      Game.LambdaHack.Common.Dice,-                      Game.LambdaHack.Common.Effect,-                      Game.LambdaHack.Common.EffectDescription,-                      Game.LambdaHack.Common.Faction,-                      Game.LambdaHack.Common.Feature,-                      Game.LambdaHack.Common.File,-                      Game.LambdaHack.Common.Flavour,-                      Game.LambdaHack.Common.Frequency,-                      Game.LambdaHack.Common.HighScore,-                      Game.LambdaHack.Common.Item,-                      Game.LambdaHack.Common.ItemDescription,-                      Game.LambdaHack.Common.ItemStrongest,-                      Game.LambdaHack.Common.Kind,-                      Game.LambdaHack.Common.Level,-                      Game.LambdaHack.Common.LQueue,-                      Game.LambdaHack.Common.Misc,-                      Game.LambdaHack.Common.MonadStateRead,-                      Game.LambdaHack.Common.Msg,-                      Game.LambdaHack.Common.Perception,-                      Game.LambdaHack.Common.PointArray,-                      Game.LambdaHack.Common.Point,-                      Game.LambdaHack.Common.Random,-                      Game.LambdaHack.Common.Save,-                      Game.LambdaHack.Common.Request,-                      Game.LambdaHack.Common.Response,-                      Game.LambdaHack.Common.State,-                      Game.LambdaHack.Common.Thread,-                      Game.LambdaHack.Common.Tile,-                      Game.LambdaHack.Common.Time,-                      Game.LambdaHack.Common.Vector,-                      Game.LambdaHack.Content.CaveKind,-                      Game.LambdaHack.Content.FactionKind,-                      Game.LambdaHack.Content.ItemKind,-                      Game.LambdaHack.Content.ModeKind,-                      Game.LambdaHack.Content.PlaceKind,-                      Game.LambdaHack.Content.RuleKind,-                      Game.LambdaHack.Content.TileKind,-                      Game.LambdaHack.SampleImplementation.SampleMonadClient,-                      Game.LambdaHack.SampleImplementation.SampleMonadServer,-                      Game.LambdaHack.Server,-                      Game.LambdaHack.Server.Commandline,-                      Game.LambdaHack.Server.CommonServer,-                      Game.LambdaHack.Server.DebugServer,-                      Game.LambdaHack.Server.DungeonGen,-                      Game.LambdaHack.Server.DungeonGen.Area,-                      Game.LambdaHack.Server.DungeonGen.AreaRnd,-                      Game.LambdaHack.Server.DungeonGen.Cave,-                      Game.LambdaHack.Server.DungeonGen.Place,-                      Game.LambdaHack.Server.EndServer,-                      Game.LambdaHack.Server.Fov,-                      Game.LambdaHack.Server.Fov.Common,-                      Game.LambdaHack.Server.Fov.Digital,-                      Game.LambdaHack.Server.Fov.Permissive,-                      Game.LambdaHack.Server.Fov.Shadow,-                      Game.LambdaHack.Server.HandleEffectServer,-                      Game.LambdaHack.Server.HandleRequestServer,-                      Game.LambdaHack.Server.ItemRev,-                      Game.LambdaHack.Server.ItemServer,-                      Game.LambdaHack.Server.LoopServer,-                      Game.LambdaHack.Server.MonadServer,-                      Game.LambdaHack.Server.PeriodicServer,-                      Game.LambdaHack.Server.ProtocolServer,-                      Game.LambdaHack.Server.StartServer,-                      Game.LambdaHack.Server.State-  other-modules:      Paths_LambdaHack-  build-depends:      array      >= 0.3.0.3 && < 1,-                      assert-failure >= 0.1 && < 1,-                      async      >= 2       && < 3,-                      base       >= 4       && < 5,-                      binary     >= 0.7     && < 1,-                      bytestring >= 0.9.2   && < 1,-                      containers >= 0.5     && < 1,-                      deepseq    >= 1.3     && < 2,-                      directory  >= 1.1.0.1 && < 2,-                      enummapset-th >= 0.6.0.0 && < 1,-                      filepath   >= 1.2.0.1 && < 2,-                      ghc-prim   >= 0.2,-                      hashable   >= 1.1.2.5 && < 2,-                      hsini      >= 0.2     && < 2,-                      keys       >= 3       && < 4,-                      miniutter  >= 0.4.1   && < 2,-                      mtl        >= 2.0.1   && < 3,-                      old-time   >= 1.0.0.7 && < 2,-                      pretty-show >= 1.6    && < 2,-                      random     >= 1.0.1   && < 2,-                      stm        >= 2.4     && < 3,-                      text       >= 0.11.2.3 && < 2,-                      transformers >= 0.3   && < 1,-                      unordered-containers >= 0.2.3 && < 1,-                      vector     >= 0.10    && < 1,-                      vector-binary-instances >= 0.2 && < 1,-                      zlib       >= 0.5.3.1 && < 1+flag supportNodeJS+  description:        compile so that the JS blob works in terminal with NodeJS+  default:            True+  manual:             True +flag jsaddle+  description:        switch to the JSaddle frontend (may be bit-rotted)+  default:            False+  manual:             True++common options   default-language:   Haskell2010-  default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings-                      BangPatterns, RecordWildCards, NamedFieldPuns-  other-extensions:   CPP, TemplateHaskell, MultiParamTypeClasses, RankNTypes,+  default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings,+                      BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf,+                      LambdaCase, DefaultSignatures, InstanceSigs,+                      PatternSynonyms, StrictData, CPP, TypeApplications+  other-extensions:   TemplateHaskell, MultiParamTypeClasses, RankNTypes,                       TypeFamilies, FlexibleContexts, FlexibleInstances,                       DeriveFunctor, FunctionalDependencies,                       GeneralizedNewtypeDeriving, TupleSections,                       DeriveFoldable, DeriveTraversable,                       ExistentialQuantification, GADTs, StandaloneDeriving,-                      DataKinds, KindSignatures---, DeriveGeneric-  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas-  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude-  ghc-options:        -fno-ignore-asserts -funbox-strict-fields-  ghc-prof-options:   -fprof-auto-calls+                      DataKinds, KindSignatures, DeriveGeneric, DeriveLift+  ghc-options:        -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists -Wpartial-fields -Wunused-packages -Winvalid-haddock+-- TODO: remove -Winvalid-haddock when added to -Wall in a GHC I use for haddock+  ghc-options:        -fno-ignore-asserts -  if flag(curses) {-    other-modules:    Game.LambdaHack.Client.UI.Frontend.Curses-    build-depends:    hscurses >= 1.4.1 && < 2-    cpp-options:      -DCURSES-  } else { if flag(vty) {-    other-modules:    Game.LambdaHack.Client.UI.Frontend.Vty-    build-depends:    vty >= 4.7.0.6 && < 5-    cpp-options:      -DVTY-  } else {-    other-modules:    Game.LambdaHack.Client.UI.Frontend.Gtk-    build-depends:    gtk >= 0.12.1 && < 0.13-  } }+  ghc-options:        -fexpose-all-unfoldings -fspecialise-aggressively -fsimpl-tick-factor=200 -executable LambdaHack-  hs-source-dirs:     GameDefinition-  main-is:            Main.hs-  other-modules:      Client.UI.Content.KeyKind,-                      Content.CaveKind,-                      Content.FactionKind,-                      Content.ItemKind,-                      Content.ItemKindActor,-                      Content.ItemKindOrgan,-                      Content.ItemKindShrapnel,-                      Content.ModeKind,-                      Content.PlaceKind,-                      Content.RuleKind,-                      Content.TileKind,-                      TieKnot,-                      Paths_LambdaHack-  build-depends:      LambdaHack,-                      template-haskell >= 2.6 && < 3,+  ghc-options:        -Wmissed-specialisations -                      array      >= 0.3.0.3 && < 1,-                      assert-failure >= 0.1 && < 1,-                      async      >= 2       && < 3,-                      base       >= 4       && < 5,-                      binary     >= 0.7     && < 1,-                      bytestring >= 0.9.2   && < 1,-                      containers >= 0.5     && < 1,-                      deepseq    >= 1.3     && < 2,-                      directory  >= 1.1.0.1 && < 2,-                      enummapset-th >= 0.6.0.0 && < 1,-                      filepath   >= 1.2.0.1 && < 2,-                      ghc-prim   >= 0.2,-                      hashable   >= 1.1.2.5 && < 2,-                      hsini      >= 0.2     && < 2,-                      keys       >= 3       && < 4,-                      miniutter  >= 0.4.1   && < 2,-                      mtl        >= 2.0.1   && < 3,-                      old-time   >= 1.0.0.7 && < 2,-                      pretty-show >= 1.6    && < 2,-                      random     >= 1.0.1   && < 2,-                      stm        >= 2.4     && < 3,-                      text       >= 0.11.2.3 && < 2,-                      transformers >= 0.3   && < 1,-                      unordered-containers >= 0.2.3 && < 1,-                      vector     >= 0.10    && < 1,-                      vector-binary-instances >= 0.2 && < 1,-                      zlib       >= 0.5.3.1 && < 1+  if flag(with_expensive_assertions)+    cpp-options:      -DWITH_EXPENSIVE_ASSERTIONS -  default-language:   Haskell2010-  default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings-                      BangPatterns, RecordWildCards, NamedFieldPuns-  other-extensions:   TemplateHaskell-  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas-  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude-  ghc-options:        -fno-ignore-asserts -funbox-strict-fields-  ghc-options:        -threaded -with-rtsopts=-C0.005 -rtsopts--- ghc-options:       -with-rtsopts=-N  -- eats all cores+  if flag(release)+    cpp-options:      -DEXPOSE_INTERNAL -test-suite test-  type:               exitcode-stdio-1.0-  hs-source-dirs:     GameDefinition, test-  main-is:            test.hs-  build-depends:      LambdaHack,-                      template-haskell >= 2.6 && < 3,+  ghcjs-options:      -DUSE_JSFILE -                      array      >= 0.3.0.3 && < 1,-                      assert-failure >= 0.1 && < 1,-                      async      >= 2       && < 3,-                      base       >= 4       && < 5,-                      binary     >= 0.7     && < 1,-                      bytestring >= 0.9.2   && < 1,-                      containers >= 0.5     && < 1,-                      deepseq    >= 1.3     && < 2,-                      directory  >= 1.1.0.1 && < 2,-                      enummapset-th >= 0.6.0.0 && < 1,-                      filepath   >= 1.2.0.1 && < 2,-                      ghc-prim   >= 0.2,-                      hashable   >= 1.1.2.5 && < 2,-                      hsini      >= 0.2     && < 2,-                      keys       >= 3       && < 4,-                      miniutter  >= 0.4.1   && < 2,-                      mtl        >= 2.0.1   && < 3,-                      old-time   >= 1.0.0.7 && < 2,-                      pretty-show >= 1.6    && < 2,-                      random     >= 1.0.1   && < 2,-                      stm        >= 2.4     && < 3,-                      text       >= 0.11.2.3 && < 2,-                      transformers >= 0.3   && < 1,-                      unordered-containers >= 0.2.3 && < 1,-                      vector     >= 0.10    && < 1,-                      vector-binary-instances >= 0.2 && < 1,-                      zlib       >= 0.5.3.1 && < 1+  if !flag(supportNodeJS)+    ghcjs-options:    -DREMOVE_TELETYPE -  default-language:   Haskell2010-  default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings-                      BangPatterns, RecordWildCards, NamedFieldPuns-  other-extensions:   TemplateHaskell-  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas-  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude-  ghc-options:        -fno-ignore-asserts -funbox-strict-fields-  ghc-options:        -threaded -with-rtsopts=-C0.005 -rtsopts+common exe-options+  ghc-options:        -rtsopts+-- (Ignored by GHCJS) Minimize median lag at the cost of occasional bigger+-- GC lag, which fortunately sometimes fits into idle time between turns):+-- (Ignored by GHCJS) Avoid frequent GCs. Only idle-GC during a break in+-- gameplay (5s), not between slow keystrokes.+  ghc-options:        "-with-rtsopts=-A99m -I5"++-- Haskell GC in GHCJS every 10s.+  ghcjs-options:      -DGHCJS_GC_INTERVAL=10000+-- This is the largest GHCJS_BUSY_YIELD value that does not cause dropped frames+-- on my machine with default --maxFps.+  ghcjs-options:      -DGHCJS_BUSY_YIELD=50+  ghcjs-options:      -dedupe++  if !flag(supportNodeJS)+    ghcjs-options:    -DGHCJS_BROWSER++library+  import: options+  hs-source-dirs:     definition-src,+                      engine-src,+                      GameDefinition/game-src,+                      GameDefinition+  exposed-modules:    Game.LambdaHack.Core.Dice+                      Game.LambdaHack.Core.Frequency+                      Game.LambdaHack.Core.Prelude+                      Game.LambdaHack.Core.Random+                      Game.LambdaHack.Definition.Ability+                      Game.LambdaHack.Definition.Color+                      Game.LambdaHack.Definition.ContentData+                      Game.LambdaHack.Definition.Defs+                      Game.LambdaHack.Definition.DefsInternal+                      Game.LambdaHack.Definition.Flavour+                      Game.LambdaHack.Content.CaveKind+                      Game.LambdaHack.Content.FactionKind+                      Game.LambdaHack.Content.ItemKind+                      Game.LambdaHack.Content.ModeKind+                      Game.LambdaHack.Content.PlaceKind+                      Game.LambdaHack.Content.RuleKind+                      Game.LambdaHack.Content.TileKind+                      Game.LambdaHack.Atomic+                      Game.LambdaHack.Atomic.CmdAtomic+                      Game.LambdaHack.Atomic.HandleAtomicWrite+                      Game.LambdaHack.Atomic.MonadStateWrite+                      Game.LambdaHack.Atomic.PosAtomicRead+                      Game.LambdaHack.Client+                      Game.LambdaHack.Client.AI+                      Game.LambdaHack.Client.AI.ConditionM+                      Game.LambdaHack.Client.AI.PickActionM+                      Game.LambdaHack.Client.AI.PickActorM+                      Game.LambdaHack.Client.AI.PickTargetM+                      Game.LambdaHack.Client.AI.Strategy+                      Game.LambdaHack.Client.Bfs+                      Game.LambdaHack.Client.BfsM+                      Game.LambdaHack.Client.CommonM+                      Game.LambdaHack.Client.HandleAtomicM+                      Game.LambdaHack.Client.HandleResponseM+                      Game.LambdaHack.Client.LoopM+                      Game.LambdaHack.Client.MonadClient+                      Game.LambdaHack.Client.Preferences+                      Game.LambdaHack.Client.Request+                      Game.LambdaHack.Client.Response+                      Game.LambdaHack.Client.State+                      Game.LambdaHack.Client.UI+                      Game.LambdaHack.Client.UI.ActorUI+                      Game.LambdaHack.Client.UI.Animation+                      Game.LambdaHack.Client.UI.Content.Input+                      Game.LambdaHack.Client.UI.Content.Screen+                      Game.LambdaHack.Client.UI.ContentClientUI+                      Game.LambdaHack.Client.UI.DrawM+                      Game.LambdaHack.Client.UI.EffectDescription+                      Game.LambdaHack.Client.UI.Frame+                      Game.LambdaHack.Client.UI.FrameM+                      Game.LambdaHack.Client.UI.Frontend+                      Game.LambdaHack.Client.UI.Frontend.Common+                      Game.LambdaHack.Client.UI.Frontend.Teletype+                      Game.LambdaHack.Client.UI.HandleHelperM+                      Game.LambdaHack.Client.UI.HandleHumanGlobalM+                      Game.LambdaHack.Client.UI.HandleHumanLocalM+                      Game.LambdaHack.Client.UI.HandleHumanM+                      Game.LambdaHack.Client.UI.HumanCmd+                      Game.LambdaHack.Client.UI.InventoryM+                      Game.LambdaHack.Client.UI.ItemDescription+                      Game.LambdaHack.Client.UI.Key+                      Game.LambdaHack.Client.UI.KeyBindings+                      Game.LambdaHack.Client.UI.MonadClientUI+                      Game.LambdaHack.Client.UI.Msg+                      Game.LambdaHack.Client.UI.MsgM+                      Game.LambdaHack.Client.UI.Overlay+                      Game.LambdaHack.Client.UI.PointUI+                      Game.LambdaHack.Client.UI.RunM+                      Game.LambdaHack.Client.UI.SessionUI+                      Game.LambdaHack.Client.UI.Slideshow+                      Game.LambdaHack.Client.UI.SlideshowM+                      Game.LambdaHack.Client.UI.TutorialHints+                      Game.LambdaHack.Client.UI.UIOptions+                      Game.LambdaHack.Client.UI.UIOptionsParse+                      Game.LambdaHack.Client.UI.Watch+                      Game.LambdaHack.Client.UI.Watch.WatchCommonM+                      Game.LambdaHack.Client.UI.Watch.WatchQuitM+                      Game.LambdaHack.Client.UI.Watch.WatchSfxAtomicM+                      Game.LambdaHack.Client.UI.Watch.WatchUpdAtomicM+                      Game.LambdaHack.Common.Analytics+                      Game.LambdaHack.Common.Area+                      Game.LambdaHack.Common.Actor+                      Game.LambdaHack.Common.ActorState+                      Game.LambdaHack.Common.ClientOptions+                      Game.LambdaHack.Common.Faction+                      Game.LambdaHack.Common.File+                      Game.LambdaHack.Common.HighScore+                      Game.LambdaHack.Common.Item+                      Game.LambdaHack.Common.ItemAspect+                      Game.LambdaHack.Common.Kind+                      Game.LambdaHack.Common.Level+                      Game.LambdaHack.Common.Misc+                      Game.LambdaHack.Common.MonadStateRead+                      Game.LambdaHack.Common.Perception+                      Game.LambdaHack.Common.PointArray+                      Game.LambdaHack.Common.Point+                      Game.LambdaHack.Common.ReqFailure+                      Game.LambdaHack.Common.RingBuffer+                      Game.LambdaHack.Common.Save+                      Game.LambdaHack.Common.State+                      Game.LambdaHack.Common.Thread+                      Game.LambdaHack.Common.Tile+                      Game.LambdaHack.Common.Time+                      Game.LambdaHack.Common.Types+                      Game.LambdaHack.Common.Vector+                      Game.LambdaHack.Server+                      Game.LambdaHack.Server.BroadcastAtomic+                      Game.LambdaHack.Server.Commandline+                      Game.LambdaHack.Server.CommonM+                      Game.LambdaHack.Server.DebugM+                      Game.LambdaHack.Server.DungeonGen+                      Game.LambdaHack.Server.DungeonGen.AreaRnd+                      Game.LambdaHack.Server.DungeonGen.Cave+                      Game.LambdaHack.Server.DungeonGen.Place+                      Game.LambdaHack.Server.Fov+                      Game.LambdaHack.Server.FovDigital+                      Game.LambdaHack.Server.HandleAtomicM+                      Game.LambdaHack.Server.HandleEffectM+                      Game.LambdaHack.Server.HandleRequestM+                      Game.LambdaHack.Server.ItemRev+                      Game.LambdaHack.Server.ItemM+                      Game.LambdaHack.Server.LoopM+                      Game.LambdaHack.Server.MonadServer+                      Game.LambdaHack.Server.PeriodicM+                      Game.LambdaHack.Server.ProtocolM+                      Game.LambdaHack.Server.ServerOptions+                      Game.LambdaHack.Server.StartM+                      Game.LambdaHack.Server.State+  exposed-modules:    Content.CaveKind+                      Content.FactionKind+                      Content.ItemKind+                      Content.ItemKindEmbed+                      Content.ItemKindActor+                      Content.ItemKindOrgan+                      Content.ItemKindBlast+                      Content.ItemKindTemporary+                      Content.ModeKind+                      Content.PlaceKind+                      Content.RuleKind+                      Content.TileKind+                      TieKnot+                      Client.UI.Content.Input+                      Client.UI.Content.Screen+                      Implementation.MonadClientImplementation+                      Implementation.MonadServerImplementation+  other-modules:      Paths_LambdaHack+  autogen-modules:    Paths_LambdaHack+  build-depends:      assert-failure >= 0.1.2 && < 0.2,+                      async      >= 2.2.1,+                      base       >= 4.10 && < 99,+                      base-compat >= 0.10.0,+                      binary     >= 0.8,+                      bytestring >= 0.9.2 ,+                      containers >= 0.5.3.0,+                      deepseq    >= 1.3,+                      directory  >= 1.1.0.1,+                      enummapset >= 0.5.2.2,+                      file-embed >= 0.0.11,+                      filepath   >= 1.2.0.1,+                      hashable   >= 1.1.2.5,+                      hsini      >= 0.2 && < 0.5.2 || >= 0.5.2.2,+                      witch      >= 0.3,+                      keys       >= 3,+                      miniutter  >= 0.5.0.0,+                      open-browser >= 0.2,+                      optparse-applicative >= 0.13,+                      pretty-show >= 1.6,+                      primitive  >= 0.6.1.0,+                      QuickCheck,+                      splitmix   >= 0.0.3,+                      stm        >= 2.4,+                      time       >= 1.4,+                      text       >= 0.11.2.3,+                      transformers >= 0.4,+                      unordered-containers >= 0.2.3,+                      vector     >= 0.11,+                      vector-binary-instances >= 0.2.3.1,+                      template-haskell >= 2.6,+                      th-lift-instances,+                      ghc-compact++  if impl(ghcjs) || flag(jsaddle) {+    exposed-modules:  Game.LambdaHack.Client.UI.Frontend.Dom+    build-depends:    ghcjs-dom >= 0.9.1.1+    cpp-options:      -DUSE_BROWSER+  } else {+    exposed-modules:  Game.LambdaHack.Client.UI.Frontend.Sdl+                      Game.LambdaHack.Client.UI.Frontend.ANSI+    build-depends:    sdl2 >= 2,+                      sdl2-ttf >= 2,+                      ansi-terminal >= 0.10+  }++  if impl(ghcjs) {+    other-modules:    Game.LambdaHack.Common.JSFile+    build-depends:    ghcjs-base+  } else {+    other-modules:    Game.LambdaHack.Common.HSFile+    build-depends:    zlib >= 0.5.3.1+  }++executable LambdaHack+  import: options, exe-options+  main-is:            GameDefinition/Main.hs+  build-depends:      ,LambdaHack+                      ,async+                      ,base+                      ,filepath+                      ,optparse-applicative++test-suite test+  import: options, exe-options+  type:               exitcode-stdio-1.0+  hs-source-dirs:     test+  main-is:            Spec.hs+  other-modules:      ActorStateUnitTests+                      CommonMUnitTests+                      HandleHelperMUnitTests+                      HandleHumanLocalMUnitTests+                      InventoryMUnitTests+                      ItemDescriptionUnitTests+                      ItemKindUnitTests+                      ItemRevUnitTests+                      LevelUnitTests+                      MonadClientUIUnitTests+                      ReqFailureUnitTests+                      SessionUIMock+                      SessionUIUnitTests+                      UnitTestHelpers+  build-depends:      ,LambdaHack+                      ,base+                      ,containers+                      ,enummapset+                      ,optparse-applicative+                      ,splitmix+                      ,tasty >= 1.0+                      ,tasty-quickcheck+                      ,tasty-hunit+                      ,text+                      ,transformers+                      ,vector
Makefile view
@@ -1,274 +1,312 @@-# All xc* tests assume a profiling build (for stack traces).-# See the install-debug target below or .travis.yml.prof.+play:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix play --dumpInitRngs -install-debug:-	cabal install --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization+shot:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix play --dumpInitRngs --printEachScreen -configure-debug:-	cabal configure --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization+expose-lore:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix know --newGame 5 --dumpInitRngs --gameMode crawl --knowItems --exposePlaces --exposeItems --exposeActors --showItemSamples --benchmark --noAnim --maxFps 1000 +dig-lore:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix know --newGame 5 --dumpInitRngs --gameMode dig --knowItems --exposePlaces --exposeItems --exposeActors --showItemSamples --benchmark --noAnim --maxFps 1000 -xcplay:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --dumpInitRngs+see-caves:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix know --newGame 5 --dumpInitRngs --gameMode see --knowItems --exposePlaces --exposeItems --exposeActors --showItemSamples --benchmark --noAnim --maxFps 1000 -xcfrontendCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1+short-caves:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix know --newGame 5 --dumpInitRngs --gameMode short --knowItems --exposePlaces --exposeItems --exposeActors --showItemSamples --benchmark --noAnim --maxFps 1000 -xcfrontendSkirmish:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish+configure-debug:+	cabal configure --enable-profiling --profiling-detail=all-functions -fwith_expensive_assertions --disable-optimization -xcfrontendAmbush:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush+configure-prof:+	cabal configure --enable-profiling --profiling-detail=exported-functions -xcfrontendBattle:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode battle --difficulty 1+ghcjs-build:+	cabal build --ghcjs . -xcfrontendSafari:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode safari --difficulty 1+chrome-log:+	google-chrome --enable-logging --v=1 file:///home/mikolaj/r/lambdahack.github.io/index.html & -xcfrontendDefense:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode defense --difficulty 9+chrome-prof:+	google-chrome --no-sandbox --js-flags="--logfile=%t.log --prof" ../lambdahack.github.io/index.html -xcbenchCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+minific:+	npx google-closure-compiler dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.1/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --externs=dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.1/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js.externs --externs=/home/mikolaj/r/lambdahack.github.io/lz-string.extern.js --jscomp_off="*" > ../lambdahack.github.io/lambdahack.all.js -xcbenchBattle:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42+minificForNode:+	npx google-closure-compiler dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.1/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --externs=/home/mikolaj/r/lambdahack.github.io/lz-string.extern.js --externs=dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.1/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js.externs --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/assert.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/child_process.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/crypto.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/dns.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/events.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/globals.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/https.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/os.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/punycode.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/readline.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/stream.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/tls.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/url.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/vm.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/buffer.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/cluster.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/dgram.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/domain.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/fs.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/http.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/net.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/path.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/querystring.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/repl.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/string_decoder.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/tty.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/util.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/zlib.js --jscomp_off="*" > ../lambdahack.github.io/lambdahack.all.js -xcbenchFrontendCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+# Low delay to display animations swiftly and not bore the public too much.+# Delay can't be lower than 2, because browsers sometimes treat delay 1+# specially and add their extra delay.+create-gif :+	find ~/.LambdaHack/screenshots/ -name 'prtscn*.bmp' -print0 | xargs -0 -r mogrify -format gif+	../gifsicle/src/gifsicle -O3 --careful -d2 --colors 255 --no-extensions --no-conserve-memory -l ~/.LambdaHack/screenshots/prtscn*.gif -o ~/.LambdaHack/screenshots/screenshot.gif -xcbenchFrontendBattle:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42+frontendRaid:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --benchMessages --gameMode raid --exposeActors -xcbenchNull: xcbenchCampaign xcbenchBattle+frontendBrawl:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode brawl --benchMessages -xcbench: xcbenchCampaign xcbenchFrontendCampaign xcbenchBattle xcbenchFrontendBattle+frontendShootout:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode shootout +frontendHunt:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode hunt -xctest-travis-short: xctest-short xcbenchNull+frontendFlight:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 3 --dumpInitRngs --automateAll --gameMode flight -xctest-travis: xctest-short xctest-medium xcbenchNull+frontendZoo:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 2 --dumpInitRngs --automateAll --gameMode zoo --exposeActors -xctest-travis-long: xctest-short xctest-long xcbenchNull+frontendAmbush:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode ambush -xctest: xctest-short xctest-medium xctest-long+frontendCrawl:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode crawl --exposeItems --exposeActors -xctest-short: xctest-short-new xctest-short-load+frontendCrawlEmpty:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode crawlEmpty --maxFps 100000 --benchmark -xctest-medium: xctestCampaign-medium xctestSkirmish-medium xctestAmbush-medium xctestBattle-medium xctestSafari-medium xctestPvP-medium xctestCoop-medium xctestDefense-medium+frontendCrawlSurvival:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 9 --dumpInitRngs --automateAll --gameMode crawlSurvival --maxFps 100000 --benchmark -xctest-long: xctestCampaign-long xctestSkirmish-long xctestAmbush-long xctestBattle-long xctestSafari-long xctestPvP-long xctestCoop-long xctestDefense-long+frontendSafari:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode safari --exposeActors -xctestCampaign-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log+frontendSafariSurvival:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode safariSurvival --exposeActors --maxFps 100000 --benchmark -xctestCampaign-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log+frontendBattle:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 4 --dumpInitRngs --automateAll --gameMode battle --exposeActors -xctestSkirmish-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log+frontendBattleDefense:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 6 --dumpInitRngs --automateAll --gameMode battleDefense --exposeActors --maxFps 100000 --benchmark -xctestSkirmish-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log+frontendBattleSurvival:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 6 --dumpInitRngs --automateAll --gameMode battleSurvival --exposeActors --maxFps 100000 --benchmark -xctestAmbush-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log+frontendDefense:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 9 --dumpInitRngs --automateAll --gameMode defense --exposeItems --exposeActors -xctestAmbush-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log+frontendDefenseEmpty:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 9 --dumpInitRngs --automateAll --gameMode defenseEmpty --maxFps 100000 --benchmark -xctestBattle-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log+fastCrawl:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode crawl --exposeItems --exposeActors --showItemSamples --noAnim --maxFps 100000 --benchmark -xctestBattle-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 150 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log+slowCrawl:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode crawl --exposeItems --exposeActors --showItemSamples -xctestSafari-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log+# different benchmarks use different arguments+RNGOPTS=--setDungeonRng "SMGen 123 123" --setMainRng "SMGen 123 125"+RNGOPTS1=--setDungeonRng "SMGen 127 123" --setMainRng "SMGen 127 125"+RNGOPTS2=--setDungeonRng "SMGen 129 123" --setMainRng "SMGen 129 125" -xctestSafari-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log+benchMemoryAnim:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 1 --maxFps 100000 --benchmark --benchMessages --stopAfterFrames 33000 --automateAll --keepAutomated --gameMode crawl $(RNGOPTS2) --frontendLazy +RTS -s -A1M -RTS -xctestPvP-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log+benchBattle:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 1500 --automateAll --keepAutomated --gameMode battle $(RNGOPTS1) -xctestPvP-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log+benchAnimBattle:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 3 --maxFps 100000 --frontendLazy --benchmark --benchMessages --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode battle $(RNGOPTS1) -xctestCoop-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log+benchFrontendBattle:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --benchmark --benchMessages --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode battle $(RNGOPTS1) -xctestCoop-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log+benchCrawl:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode crawl $(RNGOPTS) -xctestDefense-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log+benchFrontendCrawl:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --benchmark --benchMessages --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode crawl $(RNGOPTS) -xctestDefense-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log+benchDig:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 1 --automateAll --keepAutomated --gameMode dig $(RNGOPTS) -xctest-short-new:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log+benchNull: benchBattle benchAnimBattle benchCrawl -xctest-short-load:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log+bench: benchBattle benchAnimBattle benchFrontendBattle benchCrawl benchFrontendCrawl +nativeBenchCrawl:+	$$(cabal list-bin exe:LambdaHack)		   --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode crawl $(RNGOPTS) -play:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --dumpInitRngs+nativeBenchBattle:+	$$(cabal list-bin exe:LambdaHack)		   --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle $(RNGOPTS) -frontendCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1+nativeBench: nativeBenchBattle nativeBenchCrawl -frontendSkirmish:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish+nodeBenchCrawl:+	node $$(cabal list-bin exe:LambdaHack).jsexe/all.js --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode crawl $(RNGOPTS) -frontendAmbush:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush+nodeBenchBattle:+	node $$(cabal list-bin exe:LambdaHack).jsexe/all.js --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle $(RNGOPTS) -frontendBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode battle --difficulty 1+nodeBench: nodeBenchBattle nodeBenchCrawl -frontendSafari:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode safari --difficulty 1+nodeMinifiedBench:+	node ../lambdahack.github.io/lambdahack.all.js --dbgMsgSer --logPriority 4 --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle $(RNGOPTS)+	node ../lambdahack.github.io/lambdahack.all.js --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode crawl $(RNGOPTS) -frontendDefense:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 -benchCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+test: test-short test-medium benchNull -benchBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42+test-gha: test testCrawl-medium testCrawl-stopAfterGameOver testDefense-medium test-sniff -benchFrontendCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+test-short: test-short-new test-short-load -benchFrontendBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42+test-medium: testRaid-medium testBrawl-medium testShootout-medium testHunt-medium testFlight-medium testZoo-medium testAmbush-medium testCrawlEmpty-medium testCrawl-medium-know testSafari-medium testSafariSurvival-medium testBattle-medium testBattleDefense-medium testBattleSurvival-medium testDig-medium testDefenseEmpty-medium testMany-teletype -benchNull: benchCampaign benchBattle+test-sniff:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterFrames 1  --dumpInitRngs --automateAll --keepAutomated --gameMode raid --sniff > /tmp/teletypetest.log 2>&1 -bench: benchCampaign benchFrontendCampaign benchBattle benchFrontendBattle+testMany-teletype:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 9 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 50 --dumpInitRngs --automateAll --keepAutomated 2> /tmp/teletypetest.log +testMany-sdlInit:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 0 --boostRandomItem --newGame 9 --maxFps 100000 --benchmark --benchMessages --stopAfterSeconds 50 --dumpInitRngs --automateAll --keepAutomated 2> /tmp/teletypetest.log -test-travis-short: test-short benchNull+testRaid-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode raid 2> /tmp/teletypetest.log -test-travis: test-short test-medium benchNull+testBrawl-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode brawl 2> /tmp/teletypetest.log -test-travis-long: test-short test-long benchNull+testShootout-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode shootout 2> /tmp/teletypetest.log -test: test-short test-medium test-long+testHunt-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode hunt 2> /tmp/teletypetest.log -test-short: test-short-new test-short-load+testFlight-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 3 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode flight 2> /tmp/teletypetest.log -test-medium: testCampaign-medium testSkirmish-medium testAmbush-medium testBattle-medium testSafari-medium testPvP-medium testCoop-medium testDefense-medium+testZoo-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 2 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode zoo 2> /tmp/teletypetest.log -test-long: testCampaign-long testSkirmish-long testAmbush-long testBattle-long testSafari-long testPvP-long testCoop-long testDefense-long+testAmbush-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush 2> /tmp/teletypetest.log -testCampaign-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log+testCrawl-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 600 --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --assertExplored 5 2> /tmp/teletypetest.log -testCampaign-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log -testSkirmish-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log+testCrawl-stopAfterGameOver:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 9 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --stopAfterGameOver 2> /tmp/teletypetest.log -testSkirmish-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log+testCrawlEmpty-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode crawlEmpty 2> /tmp/teletypetest.log -testAmbush-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log+testCrawl-medium-know:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix know --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --knowItems --exposePlaces --exposeItems --exposeActors --showItemSamples 2> /tmp/teletypetest.log -testAmbush-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log+testSafari-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode safari 2> /tmp/teletypetest.log -testBattle-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log+testSafariSurvival-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode safariSurvival 2> /tmp/teletypetest.log  testBattle-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 150 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log--testSafari-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 3 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode battle 2> /tmp/teletypetest.log -testSafari-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log+testBattleDefense-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 7 --noAnim --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode battleDefense 2> /tmp/teletypetest.log -testPvP-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log+testBattleSurvival-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 7 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode battleSurvival 2> /tmp/teletypetest.log -testPvP-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log+testDefense-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 9 --noAnim --maxFps 100000 --frontendLazy --benchmark --stopAfterSeconds 600 --dumpInitRngs --automateAll --keepAutomated --gameMode defense 2> /tmp/teletypetest.log -testCoop-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log+testDefenseEmpty-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 9 --noAnim --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode defenseEmpty 2> /tmp/teletypetest.log -testCoop-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log+testDig-medium:+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterFrames 100 --dumpInitRngs --automateAll --keepAutomated --gameMode dig 2> /tmp/teletypetest.log -testDefense-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log+testCrawl-appveyor:+	./LambdaHack --dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterGameOver --stopAfterSeconds 300 --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --assertExplored 5 -testDefense-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log+testDefense-appveyor:+	./LambdaHack --dbgMsgSer --logPriority 4 --newGame 9 --noAnim --maxFps 100000 --frontendNull --benchmark --benchMessages --stopAfterSeconds 600 --dumpInitRngs --automateAll --keepAutomated --gameMode defense  test-short-new:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootout --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix hunt --dumpInitRngs --automateAll --keepAutomated --gameMode hunt --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix flight --dumpInitRngs --automateAll --keepAutomated --gameMode flight --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode safariSurvival --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix battle --showItemSamples --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix battleDefense --dumpInitRngs --automateAll --keepAutomated --gameMode battleDefense --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode battleSurvival --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log +# $(RNGOPTS) is needed for determinism relative to seed+# generated before game save test-short-load:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootout --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix hunt --dumpInitRngs --automateAll --keepAutomated --gameMode hunt --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix flight --dumpInitRngs --automateAll --keepAutomated --gameMode flight --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode safariSurvival --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix battleDefense --dumpInitRngs --automateAll --keepAutomated --gameMode battleDefense --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log+	$$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode battleSurvival --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log  -# The rest of the makefile is unmaintained at the moment.+build-binary-v1:+	cabal v1-install --force-reinstalls --disable-library-profiling --disable-profiling --disable-documentation --enable-optimization --only-dependencies+	cabal v1-configure --disable-library-profiling --disable-profiling --enable-optimization+	cabal v1-build exe:LambdaHack -default : dist/setup-config-	runghc Setup build+copy-binary-v1:+	cabal v1-copy --destdir=LambdaHackTheGameInstall -dist/setup-config : LambdaHack.cabal-	runghc Setup configure -fvty --user+copy-binary:+	cp $$(cabal list-bin exe:LambdaHack) LambdaHackTheGame -vty :-	runghc Setup configure -fvty --user+configure-binary-v2:+	cabal configure --disable-tests --disable-library-profiling --disable-profiling --enable-optimization -gtk :-	runghc Setup configure --user+build-binary-v2:+	cabal build --only-dependencies .+	cabal build exe:LambdaHack -curses :-	runghc Setup configure -fcurses --user+copy-directory:+	mkdir -p LambdaHackTheGame/GameDefinition+	cp GameDefinition/InGameHelp.txt LambdaHackTheGame/GameDefinition+	cp GameDefinition/PLAYING.md LambdaHackTheGame/GameDefinition+	cp README.md LambdaHackTheGame+	cp CHANGELOG.md LambdaHackTheGame+	cp LICENSE LambdaHackTheGame+	cp COPYLEFT LambdaHackTheGame+	cp CREDITS LambdaHackTheGame -clean :-	runghc Setup clean+build-binary-common: build-binary-v1 copy-directory copy-binary-v1 -ghci :-	ghci -XCPP -idist/build/autogen:.+build-binary-windows: configure-binary-v2 build-binary-v2 copy-directory++build-directory: configure-binary-v2 build-binary-v2 copy-directory copy-binary++build-binary-ubuntu: build-directory+	LambdaHackTheGame/LambdaHack --version > /dev/null; \+	LH_VERSION=$$(cat ~/.LambdaHack/stdout.txt); \+	tar -czf LambdaHack_$${LH_VERSION}_ubuntu-16.04-amd64.tar.gz LambdaHackTheGame++build-binary-macosx: build-directory+	LambdaHackTheGame/LambdaHack --version > /dev/null; \+	LH_VERSION=$$(cat ~/.LambdaHack/stdout.txt); \+	OS_VERSION=$$(sw_vers -productVersion); \+	tar -czf LambdaHack_$${LH_VERSION}_macosx-$${OS_VERSION}-amd64.tar.gz LambdaHackTheGame
README.md view
@@ -1,121 +1,349 @@-LambdaHack [![Build Status](https://secure.travis-ci.org/LambdaHack/LambdaHack.png)](http://travis-ci.org/LambdaHack/LambdaHack)[![Build Status](https://drone.io/github.com/LambdaHack/LambdaHack/status.png)](https://drone.io/github.com/LambdaHack/LambdaHack/latest)+LambdaHack ========== -This is an alpha release of LambdaHack, a [Haskell] [1] game engine-library for [roguelike] [2] games of arbitrary theme, size and complexity,-packaged together with a small example dungeon crawler. When completed,-the engine will let you specify content to be procedurally generated,-define the AI behaviour on top of the generic content-independent rules-and compile a ready-to-play game binary, using either the supplied-or a custom-made main loop. Several frontends are available-(GTK is the default) and many other generic engine components-are easily overridden, but the fundamental source of flexibility lies-in the strict and type-safe separation of code and content and of clients-(human and AI-controlled) and server. Long-term goals for LambdaHack include-support for multiplayer tactical squad combat, in-game content creation,-auto-balancing and persistent content modification based on player behaviour.+[![Hackage](https://img.shields.io/hackage/v/LambdaHack.svg)](https://hackage.haskell.org/package/LambdaHack)+[![Join the chat at Discord](https://img.shields.io/discord/688792755564052486.svg?label=chat%20on%20Discord&logo=discord&logoColor=ffffff&color=7389D8&labelColor=6A7EC2)](https://discord.gg/87Ghnws)+[![Join the chat at Matrix](https://img.shields.io/matrix/lambdahack:mozilla.org.svg?label=chat%20on%20Matrix&logo=matrix&server_fqdn=mozilla.modular.im)](https://matrix.to/#/#lambdahack:mozilla.org) -The engine comes with a sample code for a little dungeon crawler,-called LambdaHack and described in [PLAYING.md](GameDefinition/PLAYING.md).-The engine and the example game are bundled together-in a single [Hackage] [3] package. You are welcome-to create your own games by modifying the sample game-and the engine code, but please consider eventually splitting your changes-into a separate Hackage package that depends on the upstream library,-to help us exchange ideas and share improvements to the common code.+LambdaHack is a Haskell[1] game engine library for ASCII roguelike[2]+games of arbitrary theme, size and complexity, with optional+tactical squad combat. It's packaged together with a sample+dungeon crawler in a quirky fantasy setting. The sample game can be+tried out in the browser at http://lambdahack.github.io. -Games known to use the LambdaHack library:+As an example of the engine's capabilities, here is a showcase+of shooting down explosive projectiles. A couple were shot down close+enough to enemies to harm them. Others exploded closer to our party members+and took out of the air the projectiles that would otherwise harm them.+Actual in-game footage. -* [Allure of the Stars] [6], a near-future Sci-Fi game in early development-* [Space Privateers] [8], an adventure game set in far future+![gameplay screenshot](https://raw.githubusercontent.com/LambdaHack/media/master/screenshot/allureofthestars.com.shooting.down.explosives.gif) +This was a semi-automatic stealthy speedrun of the escape scenario+of the sample game, native binary, SDL2 frontend, single tiny+bitmap font. The enemy gang has a huge numerical and equipment+superiority. Our team loots the area on auto-pilot until the first foe+is spotted. Then they scout out enemy positions. Then hero 1 draws+enemies and unfortunately enemy fire as well, which is when he valiantly+shoots down explosives to avoid the worst damage. Then heroine 2 sneaks+behind enemy lines to reach the remaining treasure. That accomplished,+the captain signals retreat and leaves for the next area (the zoo). -Compilation and installation----------------------------- -The library is best compiled and installed via Cabal (already a part-of your OS distribution, or available within [The Haskell Platform] [7]),-which also takes care of all the dependencies. The latest official-version of the library can be downloaded automatically by Cabal-from [Hackage] [3] as follows+Using the engine+---------------- -    cabal install LambdaHack+To use the engine, you need to specify the content to be+procedurally generated. You declare what the game world+is made of (entities, their relations, physics and lore)+and the engine builds the world and runs it.+The library lets you compile a ready-to-play game binary,+using either the supplied or a custom-made main loop.+A couple of frontends are available (SDL2 is the default+for desktop and there is a JavaScript browser frontend)+and many other generic engine components are easily overridden,+but the fundamental source of flexibility lies in the strict+and enforced with types separation of engine code from the read-only+content and of clients (human and AI-controlled) from the server. -For a newer snapshot, download source from a development branch-at [github] [5] and run Cabal from the main directory+Please see the changelog file for recent improvements+and the issue tracker for short-term plans. Long term goals+include multiplayer tactical squad combat, in-game content+creation, auto-balancing and persistent content modification+based on player behaviour. Contributions are welcome.+Please offer feedback to mikolaj.konarski@funktory.com or, preferably,+on any of the public forums. -    cabal install+Games from different repos known to use the LambdaHack library: -For the example game, the best frontend (wrt keyboard support and colours)-is the default gtk. To compile with one of the terminal frontends,-use Cabal flags, e.g,+* Allure of the Stars[6], a near-future Sci-Fi game -    cabal install -fvty+Note: the engine and the LambdaHack sample game are bundled together+in a single Hackage[3] package released under the permissive `BSD3` license.+You are welcome to create your own games by forking and modifying+the single package, but please consider eventually splitting your changes+into a separate content-heavy package that depends on the upstream+engine library. This will help us exchange ideas and share improvements+to the common codebase. Alternatively, you can already start the development+in separation by cloning and rewriting Allure of the Stars[10]+and mix and merge with the sample LambdaHack game rules at will.+Note that the LambdaHack sample game derives from the Hack/Nethack visual+and narrative tradition[9], while Allure of the Stars uses the more free-form+Moria/Angband style (it also uses the AGPL license, and BSD3 + AGPL = AGPL,+so make sure you want to liberate your code and content to such an extent).  -Compatibility notes--------------------+Installation of the sample game from binary archives+---------------------------------------------------- -The current code was tested with GHC 7.6 and 7.8,-but should also work with other GHC versions.+The game runs rather slowly in the browser (fastest on Chrome) and you are+limited to the square font for all purposes, though it's scalable.+Also, savefiles are prone to corruption on the browser,+e.g., when it's closed while the game is still saving progress+(which takes a long time). Hence, after trying out the game,+you may prefer to use a native binary for your architecture, if it exists. -If you are using the terminal frontends, numerical keypad may not work-correctly depending on versions of the libraries, terminfo and terminal-emulators. The curses frontend is not fully supported due to the limitations-of the curses library. With the vty frontend run in an xterm,-CTRL-keypad keys for running seem to work OK, but on rxvt they do not.-Laptop (uk8o79jl) and Vi keys (hjklyubn, if enabled in config.ui.ini)-should work everywhere regardless. GTK works fine, too.+Pre-compiled game binaries are available through the release page[11]+(and Linux dev versions from GitHub Actions[18] and Windows from AppVeyor[19]).+To use a pre-compiled binary archive, unpack it and run the executable+in the unpacked directory or use program shortcuts from the installer,+if available. On Linux, make sure you have the SDL2 libraries installed+on your system (e.g., libsdl2-2.0-0 and libsdl2-ttf-2.0-0 on Ubuntu).+For Windows (XP no longer supported), the SDL2 and all other needed libraries+are included in the game's binary archive.  +Screen and keyboard configuration+---------------------------------++The game UI can be configured via a config file.+The default config settings, the same that are built into the binary,+are on github at [GameDefinition/config.ui.default](https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/config.ui.default).+When the game is run for the first time, or whenever the config file+is deleted, the file is written to the default user data location,+which is `~/.LambdaHack/` on Linux,+`C:\Users\<username>\AppData\Roaming\LambdaHack\`+(or `C:\Documents And Settings\user\Application Data\LambdaHack\`+or something else altogether) on Windows+and `Inspect/Application/Local Storage` under RMB menu+when run inside the Chrome browser.+If the user config file is outdated or corrupted, it's automatically+moved away together with old savefiles. At the next game start,+the new default config file appears at its place.++Screen fonts and, consequently, window size can be changed by editing+the config file in the user data folder. The default bitmap font+`16x16xw.bdf` used for the game map covers most national characters+in the Latin alphabet (e.g. to give custom names to player characters)+and results in a game window of exactly 720p HD dimensions. The `8x8xb.fnt`+bitmap font results in a tiny window and covers latin-1 characters only.+The config file parameter `allFontsScale` permits further window size+adjustments, automatically switching to the scalable version of the large+game map font (`16x16xw.woff`). Config file option `chosenFontset` governs+not only the main game map font, but also the shape of the rectangular fonts,+if any, in which longer texts are overlaid over the map.++For high resolution displays and/or if fullscreen mode is requested+in the configuration file, `allFontsScale` needs to be set.+E.g., scale 3 works for 4K displays. Otherwise, the letters may be+too small or, in fullscreen or on retina displays in OS X,+the screen may be automatically scaled as a whole, not each letter+separately, softening letter edges of the square fonts that should+rather be pixel-perfect and crisp.++If you don't have a numeric keypad, you can use the left-hand movement+key setup (axwdqezc) or Vi editor keys (aka roguelike keys) or mouse.+If numeric keypad doesn't work, toggling the Num Lock key sometimes helps.+If running with the Shift key and keypad keys doesn't work,+try the Control key instead. The game is fully playable with mouse only,+as well as with keyboard only, but the most efficient combination+may be mouse for menus, go-to, inspecting the map, aiming at distant+positions and keyboard for everything else.++If you run the ANSI terminal frontend (`--frontendANSI` on commandline),+then numeric keypad (especially keypad `*`, `/` and `5`) may not work+correctly, depending on the terminal emulator you use. Toggling+the Num Lock key may help or make issues worse. As a work around+these issues, numbers are used for movement in the ANSI frontend,+which sadly prevents the number keys from selecting heroes.+The commands that require pressing Control and Shift together won't work+either, but fortunately they are not crucial to gameplay.++Some effort went into making the ANSI frontend usable with screen readers,+but without feedback it's hard to say how accessible that setup is.+This doesn't work on Windows, due to extra code that would be required.+As a side effect of screen reader support, there is no aiming line+nor path in ANSI frontend and some of map position highlighting+is performed using the terminal cursor. Screen readers may also work+better with animations turned off, using `--noAnim` or the corresponding+config file or main game menu options.+++Compilation of the library and sample game from source+------------------------------------------------------++To compile with the standard frontend based on SDL2, you need the SDL2+libraries for your OS. On Linux, remember to install the -dev versions+as well, e.g., libsdl2-dev and libsdl2-ttf-dev on Ubuntu Linux 16.04.+Compilation to JavaScript for the browser is more complicated+and requires the ghcjs[15] compiler and optionally the Google Closure+Compiler[16].++The latest official version of the LambdaHack library can be downloaded,+compiled for SDL2 and installed automatically using the 'cabal' tool,+which may already be a part of your OS distribution, but if it's too old+(version 3.4 or later is required) you can download the whole current+compilation suite as described at https://www.haskell.org/downloads/.+You can get and run the LambdaHack package from Hackage[3] as follows++    cabal update+    cabal install LambdaHack+    ~/.cabal/bin/LambdaHack++For a newer snapshot, clone the source code from github[5]+and run `cabal run LambdaHack` from the main directory.+Alternatively, if you'd like to develop in this codebase,+the following speeds up the turn-around a lot++    cp cabal.project.local.development cabal.project.local++and then you can compile (and recompile) with++    cabal build++and run the game with++    make play++The SDL2 frontend binary also contains the ANSI terminal frontend+(`--frontendANSI` on commandline) intended for screen readers+and a simplified black and white line terminal frontend (`--frontendTeletype`)+suitable for teletype terminals or a keyboard and a printer (but it's going+to use a lot of paper, unless you disable animations with `--noAnim`).+The teletype frontend is used in CI and for some tests and benchmarks defined+in Makefile. The terminal frontends leave you on your own regarding font+choice and color setup and you won't have the colorful squares outlining+special positions that exist in the SDL2 frontend, but only crude+cursor highlights. The terminal frontends should run on Windows,+but Windows disables console for GUI applications, so they don't.++ Testing and debugging --------------------- -The [Makefile](Makefile) contains many sample test commands.-All commands that use the screensaver game modes (AI vs. AI)- and the dumb `stdout` frontend are gathered in `make test`.-Of these, travis runs `test-travis-*` on each push to the repo.-Test commands with prefix `frontend` start AI vs. AI games-with the standard, user-friendly frontend.+Unit tests and integration tests can be run and displayed with +    cabal test --test-show-details=direct++and doctests with++    cabal install doctest --overwrite-policy=always && cabal build+    cabal repl --build-depends=QuickCheck --with-ghc=doctest definition+    cabal repl --build-depends=QuickCheck --build-depends=template-haskell --with-ghc=doctest lib:LambdaHack++The [Makefile](https://github.com/LambdaHack/LambdaHack/blob/master/Makefile)+contains many sample automated playtest commands.+Numerous tests that use the screensaver game modes (AI vs. AI)+and the teletype frontend are gathered in `make test-locally`.+Some of these are run by CI  on each push to github.+Test commands with prefix `frontend` start AI vs. AI games with+the standard SDL2 frontend to view them on.+ Run `LambdaHack --help` to see a brief description of all debug options.-Of these, `--sniffIn` and `--sniffOut` are very useful (though verbose-and initially cryptic), for monitoring the traffic between clients-and the server. Some options in the config file may prove useful too,-though they mostly overlap with commandline options (and will be totally-merged at some point).+Of these, the `--sniff` option is very useful (though verbose+and initially cryptic), for displaying the traffic between clients+and the server. Some options in the config file may prove useful+for debugging too, though they mostly overlap with commandline options+(and will be totally merged at some point). -You can use HPC with the game as follows (a quick manual playing session-after the automated tests would be in order, as well, since the tests don't-touch the topmost UI layer). -    cabal clean-    cabal install --enable-library-coverage-    make test-    hpc report --hpcdir=dist/hpc/mix/LambdaHack-0.2.14/ LambdaHack-    hpc markup --hpcdir=dist/hpc/mix/LambdaHack-0.2.14/ LambdaHack+Coding style+------------ -Note that debug option `--stopAfter` is required to cleanly terminate-any automated test that is used to gather HPC info, because HPC needs-a clean exit (to save data files).+Stylish Haskell is used for slight auto-formatting at buffer save; see+[.stylish-haskell.yaml](https://github.com/LambdaHack/LambdaHack/blob/master/.stylish-haskell.yaml).+As defined in the file, indentation is 2 spaces wide and screen is+80-columns wide. Spaces are used, not tabs. Spurious whitespace avoided.+Spaces around arithmetic operators encouraged.+Generally, relax and try to stick to the style apparent in a file+you are editing. Put big formatting changes in separate commits. +CI checks the code with `hlint .` using the very liberal configuration file at+[.hlint.yaml](https://github.com/LambdaHack/LambdaHack/blob/master/.hlint.yaml).+If hlint is still too naggy, feel free to add more exceptions. +Haddocks are provided for all module headers and for all functions and types+from major modules, in particular for the modules that are interfaces+for a whole directory of modules. Apart of that, only very important+functions and types are distinguished by having a haddock.+If minor ones have comments, they should not be haddocks+and they are permitted to describe implementation details and be out of date.+Prefer assertions instead of comments, unless too verbose.++The 'pointman' from game manual and UI is called 'leader' in the source code+and there are a few more mismatches, though the source code naming+and the UI naming should each be consistent in separation.+If the UI names stick, perhaps source code will be renamed at some point.++This codebase is an experiment in extensive use of states without lens.+So far, it works, doesn't result in much larger files or lots+of repetition and has the added benefits that newcomers don't need+to learn any optics library. Record punning, etc., definitely help.+++First steps reading the codebase+--------------------------------++A good start may be++https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/game-src/Client/UI/Content/Input.hs++That's where keyboard keys are assigned commands, help texts and categories+(including special categories indicating that a group of keys+also forms an in-game menu). This file is specific to a particular game+(hence `GameDefinition` in the path) and the engine dynamically creates+in-game help screens based on this file and on player config file+that can partially overwrite it.++The commands assigned to keys are interpreted by the UI client+(each faction in the game uses a client and the player's client additionally+has UI capabilities) in the following module:++https://github.com/LambdaHack/LambdaHack/blob/master/engine-src/Game/LambdaHack/Client/UI/HandleHumanM.hs++By this point you've seen one of the six major command sets (`HumanCmd`,+the others being `Effect`, `UpdAtomic`, `Request`, `Response`, `FrontReq`)+and one of around ten distinct interpreters for the commands+(mostly in `Handle*` modules). You've also seen a bit of the UI+client code, but not the AI client nor the server (game arbiter) code.+The wiki[17] contains not entirely outdated further reading about+the client-server architecture.++At this point, before trying to grasp anything more and drown in abstraction,+you are welcome to pick up a few `good first issue`-labeled tickets+and get some hands-on experience with the codebase.++For further study, note that most of the commands are interpreted in monads.+Server and clients share some of the customized monadic API, but their+monads are implemented differently (in `*Implementation` modules).+All these monads are state monads (managing different aspects of game state),+therefore the semantics of a command is a state transformer with extra+side effects (e.g., frontend drawing).++The "main loop" is the following: the UI client receives keystrokes+and interprets the commands they correspond to. As soon as one of the commands+is not just local UI manipulation, but a request to change the main game state,+such a request is packaged and sent to the server (e.g., a request+to move a hero to the north). The server responds "not possible,+there is a wall" or reacts by sending to clients (to all UI and AI clients+that can see the event) a series of game state-changing responses.+AI clients, likewise, send to the server requests, generated based+on the perceived game state changes and the AI goals of each AI faction.++ Further information ------------------- -For more information, visit the [wiki] [4]-and see [PLAYING.md](GameDefinition/PLAYING.md), [CREDITS](CREDITS)-and [LICENSE](LICENSE).+For more information, visit the wiki[4]+and see [PLAYING.md](https://github.com/LambdaHack/LambdaHack/blob/master/GameDefinition/PLAYING.md),+[CREDITS](https://github.com/LambdaHack/LambdaHack/blob/master/CREDITS)+and [COPYLEFT](https://github.com/LambdaHack/LambdaHack/blob/master/COPYLEFT).  Have fun!   -[1]: http://www.haskell.org/+[1]: https://www.haskell.org/ [2]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation-[3]: http://hackage.haskell.org/package/LambdaHack+[3]: https://hackage.haskell.org/package/LambdaHack [4]: https://github.com/LambdaHack/LambdaHack/wiki-[5]: http://github.com/LambdaHack/LambdaHack+[5]: https://github.com/LambdaHack/LambdaHack [6]: http://allureofthestars.com-[7]: http://www.haskell.org/platform-[8]: https://github.com/tuturto/space-privateers+[9]: https://github.com/LambdaHack/LambdaHack/wiki/Sample-dungeon-crawler+[10]: https://github.com/AllureOfTheStars/Allure+[11]: https://github.com/LambdaHack/LambdaHack/releases+[15]: https://github.com/ghcjs/ghcjs+[16]: https://www.npmjs.com/package/google-closure-compiler+[17]: https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture+[18]: https://github.com/LambdaHack/LambdaHack/actions+[19]: https://ci.appveyor.com/project/Mikolaj/lambdahack
+ cabal.project view
@@ -0,0 +1,7 @@+packages: ./++package sdl2+    flags: +no-linear++package splitmix+    flags: +optimised-mixer
+ definition-src/Game/LambdaHack/Content/CaveKind.hs view
@@ -0,0 +1,148 @@+-- | The type of cave kinds. Every level in the game is an instantiated+-- cave kind.+module Game.LambdaHack.Content.CaveKind+  ( pattern DEFAULT_RANDOM+  , CaveKind(..), InitSleep(..), makeData+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , validateSingle, validateAll, mandatoryGroups+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Text as T++import           Game.LambdaHack.Content.ItemKind (ItemKind)+import           Game.LambdaHack.Content.PlaceKind (PlaceKind)+import qualified Game.LambdaHack.Content.RuleKind as RK+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.ContentData+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.DefsInternal++-- | Parameters for the generation of dungeon levels.+-- Warning: for efficiency, avoid embedded items in any of the common tiles.+data CaveKind = CaveKind+  { cname         :: Text             -- ^ short description+  , cfreq         :: Freqs CaveKind   -- ^ frequency within groups+  , cXminSize     :: X                -- ^ minimal X size of the whole cave+  , cYminSize     :: Y                -- ^ minimal Y size of the whole cave+  , ccellSize     :: Dice.DiceXY      -- ^ size of a map cell holding a place+  , cminPlaceSize :: Dice.DiceXY      -- ^ minimal size of places; for merging+  , cmaxPlaceSize :: Dice.DiceXY      -- ^ maximal size of places; for growing+  , cdarkOdds     :: Dice.Dice        -- ^ the odds a place is dark+                                      --   (level-scaled dice roll > 50)+  , cnightOdds    :: Dice.Dice        -- ^ the odds the cave is dark+                                      --   (level-scaled dice roll > 50)+  , cauxConnects  :: Rational         -- ^ a proportion of extra connections+  , cmaxVoid      :: Rational+      -- ^ at most this proportion of rooms may be void+  , cdoorChance   :: Chance           -- ^ the chance of a door in an opening+  , copenChance   :: Chance           -- ^ if there's a door, is it open?+  , chidden       :: Int              -- ^ if not open, hidden one in n times+  , cactorCoeff   :: Int              -- ^ the lower, the more monsters spawn+  , cactorFreq    :: Freqs ItemKind   -- ^ actor groups to consider+  , citemNum      :: Dice.Dice        -- ^ number of initial items in the cave+  , citemFreq     :: Freqs ItemKind   -- ^ item groups to consider;+      -- note that the groups are flattened; e.g., if an item is moved+      -- to another included group with the same weight, the outcome+      -- doesn't change+  , cplaceFreq    :: Freqs PlaceKind  -- ^ place groups to consider+  , cpassable     :: Bool+      -- ^ are passable default tiles permitted+  , clabyrinth    :: Bool                -- ^ waste of time for AI to explore+  , cdefTile      :: GroupName TileKind  -- ^ the default cave tile+  , cdarkCorTile  :: GroupName TileKind  -- ^ the dark cave corridor tile+  , clitCorTile   :: GroupName TileKind  -- ^ the lit cave corridor tile+  , cwallTile     :: GroupName TileKind  -- ^ the tile used for @FWall@ fence+  , ccornerTile   :: GroupName TileKind  -- ^ tile used for the fence corners+  , cfenceTileN   :: GroupName TileKind  -- ^ the outer fence N wall+  , cfenceTileE   :: GroupName TileKind  -- ^ the outer fence E wall+  , cfenceTileS   :: GroupName TileKind  -- ^ the outer fence S wall+  , cfenceTileW   :: GroupName TileKind  -- ^ the outer fence W wall+  , cfenceApart   :: Bool                -- ^ are places touching fence banned+  , cminStairDist :: Int                 -- ^ minimal distance between stairs+  , cmaxStairsNum :: Dice.Dice           -- ^ maximum number of stairs+  , cescapeFreq   :: Freqs PlaceKind     -- ^ escape groups, if any+  , cstairFreq    :: Freqs PlaceKind     -- ^ place groups for created stairs+  , cstairAllowed :: Freqs PlaceKind     -- ^ extra groups for inherited+  , cskip         :: [Int]  -- ^ which faction starting positions to skip+  , cinitSleep    :: InitSleep           -- ^ whether actors spawn sleeping+  , cdesc         :: Text   -- ^ full cave description+  }+  deriving Show  -- No Eq and Ord to make extending logically sound++data InitSleep = InitSleepAlways | InitSleepPermitted | InitSleepBanned+  deriving (Show, Eq)++-- | Catch caves with not enough space for all the places. Check the size+-- of the cave descriptions to make sure they fit on screen. Etc.+validateSingle :: RK.RuleContent -> CaveKind -> [Text]+validateSingle corule CaveKind{..} =+  let (minCellSizeX, minCellSizeY) = Dice.infDiceXY ccellSize+      (maxCellSizeX, maxCellSizeY) = Dice.supDiceXY ccellSize+      (minMinSizeX, minMinSizeY) = Dice.infDiceXY cminPlaceSize+      (maxMinSizeX, maxMinSizeY) = Dice.supDiceXY cminPlaceSize+      (minMaxSizeX, minMaxSizeY) = Dice.infDiceXY cmaxPlaceSize+  in [ "cname longer than 25" | T.length cname > 25 ]+     ++ [ "cXminSize > RK.rWidthMax" | cXminSize > RK.rWidthMax corule ]+     ++ [ "cYminSize > RK.rHeightMax" | cYminSize > RK.rHeightMax corule ]+     ++ [ "cXminSize < 8" | cXminSize < 8 ]+     ++ [ "cYminSize < 8" | cYminSize < 8 ]  -- see @focusArea@+     ++ [ "cXminSize - 2 < maxCellSizeX" | cXminSize - 2 < maxCellSizeX ]+     ++ [ "cYminSize - 2 < maxCellSizeY" | cYminSize - 2 < maxCellSizeY ]+     ++ [ "minCellSizeX < 2" | minCellSizeX < 2 ]+     ++ [ "minCellSizeY < 2" | minCellSizeY < 2 ]+     ++ [ "minCellSizeX < 4 and stairs"+        | minCellSizeX < 4 && not (null cstairFreq) ]+     ++ [ "minCellSizeY < 4 and stairs"+        | minCellSizeY < 4 && not (null cstairFreq) ]+     -- The following four are heuristics, so not too restrictive:+     ++ [ "minCellSizeX < 6 && non-trivial stairs"+        | minCellSizeX < 6 && not (length cstairFreq <= 1 && null cescapeFreq) ]+     ++ [ "minCellSizeY < 4 && non-trivial stairs"+        | minCellSizeY < 4 && not (length cstairFreq <= 1 && null cescapeFreq) ]+     ++ [ "minMinSizeX < 5 && non-trivial stairs"+        | minMinSizeX < 5 && not (length cstairFreq <= 1 && null cescapeFreq) ]+     ++ [ "minMinSizeY < 3 && non-trivial stairs"+        | minMinSizeY < 3 && not (length cstairFreq <= 1 && null cescapeFreq) ]+     ++ [ "minMinSizeX < 1" | minMinSizeX < 1 ]+     ++ [ "minMinSizeY < 1" | minMinSizeY < 1 ]+     ++ [ "minMaxSizeX < maxMinSizeX" | minMaxSizeX < maxMinSizeX ]+     ++ [ "minMaxSizeY < maxMinSizeY" | minMaxSizeY < maxMinSizeY ]+     ++ [ "chidden < 0" | chidden < 0 ]+     ++ [ "cactorCoeff < 0" | cactorCoeff < 0 ]+     ++ [ "citemNum < 0" | Dice.infDice citemNum < 0 ]+     ++ [ "cmaxStairsNum < 0" | Dice.infDice cmaxStairsNum < 0 ]+     ++ [ "stairs suggested, but not defined"+        | Dice.supDice cmaxStairsNum > 0 && null cstairFreq ]++-- | Validate all cave kinds.+-- Note that names don't have to be unique: we can have several variants+-- of a cave with a given name.+validateAll :: [CaveKind] -> ContentData CaveKind -> [Text]+validateAll _ _ = []  -- so far, always valid++-- * Mandatory item groups++mandatoryGroups :: [GroupName CaveKind]+mandatoryGroups =+       [DEFAULT_RANDOM]++pattern DEFAULT_RANDOM :: GroupName CaveKind++pattern DEFAULT_RANDOM = GroupName "default random"++makeData :: RK.RuleContent+         -> [CaveKind] -> [GroupName CaveKind] -> [GroupName CaveKind]+         -> ContentData CaveKind+makeData corule content groupNamesSingleton groupNames =+  makeContentData "CaveKind" cname cfreq (validateSingle corule) validateAll+                  content+                  groupNamesSingleton+                  (mandatoryGroups ++ groupNames)
+ definition-src/Game/LambdaHack/Content/FactionKind.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | The type of kinds of factions present in a game, both human+-- and computer-controlled.+module Game.LambdaHack.Content.FactionKind+  ( FactionKind(..), makeData+  , HiCondPoly, HiSummand, HiPolynomial, HiIndeterminant(..)+  , TeamContinuity(..), Outcome(..)+  , teamExplorer, hiHeroLong, hiHeroMedium, hiHeroShort, hiDweller+  , victoryOutcomes, deafeatOutcomes+  , nameOutcomePast, nameOutcomeVerb, endMessageOutcome+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , validateSingle, validateAll+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.Text as T+import           GHC.Generics (Generic)++import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.ContentData+import           Game.LambdaHack.Definition.Defs++-- | Properties of a particular faction.+data FactionKind = FactionKind+  { fname         :: Text        -- ^ name of the faction+  , ffreq         :: Freqs FactionKind+                                 -- ^ frequency within groups+  , fteam         :: TeamContinuity+                                 -- ^ the team the faction identifies with+                                 --   across games and modes+  , fgroups       :: Freqs ItemKind+      -- ^ names of actor groups that may naturally fall under faction's+      --   control, e.g., upon spawning; make sure all groups that may+      --   ever continuousely generate actors, e.g., through spawning+      --   or summoning, are mentioned in at least one faction kind;+      --   groups of initial faction actors don't need to be included+  , fskillsOther  :: Ability.Skills+                                 -- ^ fixed skill modifiers to the non-leader+                                 --   actors; also summed with skills implied+                                 --   by @fdoctrine@ (which is not fixed)+  , fcanEscape    :: Bool        -- ^ the faction can escape the dungeon+  , fneverEmpty   :: Bool        -- ^ the faction declared killed if no actors+  , fhiCondPoly   :: HiCondPoly  -- ^ score formula (conditional polynomial)+  , fhasGender    :: Bool        -- ^ whether actors have gender+  , finitDoctrine :: Ability.Doctrine+                                 -- ^ initial faction's non-leaders doctrine+  , fspawnsFast   :: Bool+      -- ^ spawns fast enough that switching pointman to another level+      --   to optimize spawning is a winning tactics, which would spoil+      --   the fun, so switching is disabled in UI and AI clients+  , fhasPointman  :: Bool        -- ^ whether the faction can have a pointman+  , fhasUI        :: Bool        -- ^ does the faction have a UI client+                                 --   (for control or passive observation)+  , finitUnderAI  :: Bool        -- ^ is the faction initially under AI control+  , fenemyTeams   :: [TeamContinuity]+                                 -- ^ teams starting at war with the faction+  , falliedTeams  :: [TeamContinuity]+                                 -- ^ teams starting allied with the faction+  }+  deriving (Show, Eq, Generic)++instance Binary FactionKind++-- | Team continuity index. Starting with 1. See the comment for `FactionId`.+newtype TeamContinuity = TeamContinuity Int+  deriving (Show, Eq, Ord, Enum, Generic)++instance Binary TeamContinuity++-- | Conditional polynomial representing score calculation for this faction.+type HiCondPoly = [HiSummand]++type HiSummand = (HiPolynomial, [Outcome])++type HiPolynomial = [(HiIndeterminant, Double)]++data HiIndeterminant =+    HiConst+  | HiLoot+  | HiSprint+  | HiBlitz+  | HiSurvival+  | HiKill+  | HiLoss+  deriving (Show, Eq, Generic)++instance Binary HiIndeterminant++-- | Outcome of a game.+data Outcome =+    Escape    -- ^ the faction escaped the dungeon alive+  | Conquer   -- ^ the faction won by eliminating all rivals+  | Defeated  -- ^ the faction lost the game in another way+  | Killed    -- ^ the faction was eliminated+  | Restart   -- ^ game is restarted; the quitter quit+  | Camping   -- ^ game is supended+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary Outcome++teamExplorer :: TeamContinuity+teamExplorer = TeamContinuity 1++hiHeroLong, hiHeroMedium, hiHeroShort, hiDweller :: HiCondPoly++hiHeroShort =+  [ ( [(HiLoot, 100)]+    , [minBound..maxBound] )+  , ( [(HiConst, 100)]+    , victoryOutcomes )+  , ( [(HiSprint, -500)]  -- speed matters, but only if fast enough+    , victoryOutcomes )+  , ( [(HiSurvival, 10)]  -- few points for surviving long+    , deafeatOutcomes )+  ]++hiHeroMedium =+  [ ( [(HiLoot, 200)]  -- usually no loot, but if so, no harm+    , [minBound..maxBound] )+  , ( [(HiConst, 200), (HiLoss, -10)]  -- normally, always positive+    , victoryOutcomes )+  , ( [(HiSprint, -1000)]  -- speed matters, but only if fast enough+    , victoryOutcomes )+  , ( [(HiBlitz, -100)]  -- speed matters always+    , victoryOutcomes )+  , ( [(HiSurvival, 10)]  -- few points for surviving long+    , deafeatOutcomes )+  ]++-- Heroes in long crawls rejoice in loot. But speedrunning just as valuable.+hiHeroLong =+  [ ( [(HiLoot, 10000)]  -- multiplied by fraction of collected+    , [minBound..maxBound] )+  , ( [(HiConst, 15)]  -- a token bonus in case all loot lost, but victory+    , victoryOutcomes )+  , ( [(HiSprint, -20000)]  -- speedrun bonus, if below this number of turns+    , victoryOutcomes )+  , ( [(HiBlitz, -100)]  -- speed matters always+    , victoryOutcomes )+  , ( [(HiSurvival, 10)]  -- few points for surviving long+    , deafeatOutcomes )+  ]++-- Spawners get no points from loot, but try to kill+-- all opponents fast or at least hold up for long.+hiDweller = [ ( [(HiConst, 1000)]  -- no loot, so big win reward+              , victoryOutcomes )+            , ( [(HiConst, 1000), (HiLoss, -10)]+              , victoryOutcomes )+            , ( [(HiSprint, -1000)]  -- speedrun bonus, if below+              , victoryOutcomes )+            , ( [(HiBlitz, -100)]  -- speed matters+              , victoryOutcomes )+            , ( [(HiSurvival, 100)]+              , deafeatOutcomes )+            ]++victoryOutcomes :: [Outcome]+victoryOutcomes = [Escape, Conquer]++deafeatOutcomes :: [Outcome]+deafeatOutcomes = [Defeated, Killed, Restart]++nameOutcomePast :: Outcome -> Text+nameOutcomePast = \case+  Escape   -> "emerged victorious"+  Conquer  -> "vanquished all opposition"+  Defeated -> "got decisively defeated"+  Killed   -> "got eliminated"+  Restart  -> "resigned prematurely"+  Camping  -> "set camp"++nameOutcomeVerb :: Outcome -> Text+nameOutcomeVerb = \case+  Escape   -> "emerge victorious"+  Conquer  -> "vanquish all opposition"+  Defeated -> "be decisively defeated"+  Killed   -> "be eliminated"+  Restart  -> "resign prematurely"+  Camping  -> "set camp"++endMessageOutcome :: Outcome -> Text+endMessageOutcome = \case+  Escape   -> "Can it be done more efficiently, though?"+  Conquer  -> "Can it be done in a better style, though?"+  Defeated -> "Let's hope your new overlords let you live."+  Killed   -> "Let's hope a rescue party arrives in time!"+  Restart  -> "This time for real."+  Camping  -> "See you soon, stronger and braver!"++validateSingle :: FactionKind -> [Text]+validateSingle FactionKind{..} =+  [ "fname longer than 50" | T.length fname > 50 ]+  ++ [ "fskillsOther not negative:" <+> fname+     | any ((>= 0) . snd) $ Ability.skillsToList fskillsOther ]+  ++ let checkLoveHate l team =+           [ "love-hate relationship for" <+> tshow team | team `elem` l ]+     in concatMap (checkLoveHate fenemyTeams) falliedTeams+  ++ let checkDipl field l team =+           [ "self-diplomacy in" <+> field | length (elemIndices team l) > 1 ]+     in concatMap (checkDipl "fenemyTeams" fenemyTeams) fenemyTeams+        ++ concatMap (checkDipl "falliedTeams" falliedTeams) falliedTeams++-- | Validate game faction kinds together.+validateAll :: [FactionKind] -> ContentData FactionKind -> [Text]+validateAll _ _ = []  -- so far, always valid++makeData :: [FactionKind] -> [GroupName FactionKind] -> [GroupName FactionKind]+         -> ContentData FactionKind+makeData = makeContentData "FactionKind" fname ffreq validateSingle validateAll
+ definition-src/Game/LambdaHack/Content/ItemKind.hs view
@@ -0,0 +1,763 @@+{-# LANGUAGE DeriveGeneric #-}+-- | The type of kinds of weapons, treasure, organs, blasts, etc.+module Game.LambdaHack.Content.ItemKind+  ( pattern CONDITION, pattern COMMON_ITEM, pattern S_BONUS_HP, pattern S_BRACED, pattern S_ASLEEP, pattern S_IMPRESSED, pattern S_CURRENCY, pattern MOBILE+  , pattern CRAWL_ITEM, pattern TREASURE, pattern ANY_SCROLL, pattern ANY_GLASS, pattern ANY_POTION, pattern ANY_FLASK, pattern EXPLOSIVE, pattern ANY_JEWELRY, pattern S_SINGLE_SPARK, pattern S_SPARK, pattern S_FRAGRANCE+  , pattern HORROR, pattern VALUABLE, pattern UNREPORTED_INVENTORY, pattern AQUATIC+  , ItemKind(..), makeData+  , Aspect(..), Effect(..), Condition(..), DetectKind(..)+  , TimerDice, ThrowMod(..)+  , ItemSymbolsUsedInEngine(..), emptyItemSymbolsUsedInEngine+  , boostItemKindList, forApplyEffect, forDamageEffect, isDamagingKind+  , strengthOnCombine, strengthOnSmash, getDropOrgans+  , getMandatoryPresentAsFromKind, isEffEscape, isEffEscapeOrAscend+  , timeoutAspect, orEffect, onSmashEffect, onCombineEffect, alwaysDudEffect+  , damageUsefulness, verbMsgNoLonger, verbMsgLess, toVelocity, toLinger+  , timerNone, isTimerNone, foldTimer, toOrganBad, toOrganGood, toOrganNoTimer+  , validateSingle+  , mandatoryGroups, mandatoryGroupsSingleton+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , boostItemKind, onSmashOrCombineEffect+  , validateAll, validateDups, validateDamage+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import           Data.Hashable (Hashable)+import qualified Data.Text as T+import           GHC.Generics (Generic)+import qualified System.Random.SplitMix32 as SM++import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random (nextRandom)+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.ContentData+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.DefsInternal+import           Game.LambdaHack.Definition.Flavour++-- * Mandatory item groups++mandatoryGroupsSingleton :: [GroupName ItemKind]+mandatoryGroupsSingleton =+       [S_BONUS_HP, S_BRACED, S_ASLEEP, S_IMPRESSED, S_CURRENCY]++pattern S_BONUS_HP, S_BRACED, S_ASLEEP, S_IMPRESSED, S_CURRENCY :: GroupName ItemKind++mandatoryGroups :: [GroupName ItemKind]+mandatoryGroups =+       [CONDITION, COMMON_ITEM, MOBILE]++pattern CONDITION, COMMON_ITEM, MOBILE :: GroupName ItemKind++-- From Preferences.hs++pattern CONDITION = GroupName "condition"+pattern COMMON_ITEM = GroupName "common item"++-- Assorted++pattern S_BONUS_HP = GroupName "bonus HP"+pattern S_BRACED = GroupName "braced"+pattern S_ASLEEP = GroupName "asleep"+pattern S_IMPRESSED = GroupName "impressed"+pattern S_CURRENCY = GroupName "currency"+pattern MOBILE = GroupName "mobile"++-- * Optional item groups++pattern S_SINGLE_SPARK, S_SPARK, S_FRAGRANCE, CRAWL_ITEM, TREASURE, ANY_SCROLL, ANY_GLASS, ANY_POTION, ANY_FLASK, EXPLOSIVE, ANY_JEWELRY, VALUABLE, UNREPORTED_INVENTORY, AQUATIC, HORROR :: GroupName ItemKind++-- Used in Preferences.hs++pattern S_SINGLE_SPARK = GroupName "single spark"+pattern S_SPARK = GroupName "spark"+pattern S_FRAGRANCE = GroupName "fragrance"++pattern CRAWL_ITEM = GroupName "curious item"+  -- to be used only in long scenarios, such as multi-level dungeon crawl;+  -- may be a powerful or a mundate item, unlike @TREASURE@ item+pattern TREASURE = GroupName "treasure"+  -- particularly powerful items, but may appear in any scenario+pattern ANY_SCROLL = GroupName "scroll"+pattern ANY_GLASS = GroupName "glass"+pattern ANY_POTION = GroupName "potion"+pattern ANY_FLASK = GroupName "flask"+pattern EXPLOSIVE = GroupName "explosive"+pattern ANY_JEWELRY = GroupName "jewelry"++-- * Used elsewhere++pattern VALUABLE = GroupName "valuable"+pattern UNREPORTED_INVENTORY = GroupName "unreported inventory"+pattern AQUATIC = GroupName "aquatic"++pattern HORROR = GroupName "horror"++-- | Item properties that are fixed for a given kind of items.+-- Of these, aspects and effects are jointly called item powers.+-- Note that this type is mutually recursive with 'Effect' and `Aspect`.+data ItemKind = ItemKind+  { isymbol  :: ContentSymbol ItemKind+                                -- ^ map symbol+  , iname    :: Text            -- ^ generic name; is pluralized if needed+  , ifreq    :: Freqs ItemKind  -- ^ frequency within groups+  , iflavour :: [Flavour]       -- ^ possible flavours+  , icount   :: Dice.Dice       -- ^ created in that quantity+  , irarity  :: Rarity          -- ^ rarity on given depths+  , iverbHit :: Text            -- ^ the verb for hitting+  , iweight  :: Int             -- ^ weight in grams+  , idamage  :: Dice.Dice       -- ^ basic kinetic damage+  , iaspects :: [Aspect]        -- ^ affect the actor continuously+  , ieffects :: [Effect]        -- ^ cause the effects when triggered+  , ikit     :: [(GroupName ItemKind, CStore)]+                                -- ^ accompanying organs and equipment+  , idesc    :: Text            -- ^ description+  }+  deriving Show  -- No Eq and Ord to make extending logically sound++-- | Aspects of items. Aspect @AddSkill@ is additive (starting at 0)+-- for all items wielded by an actor and it affects the actor.+-- The others affect only the item in question, not the actor carrying it,+-- and so are not additive in any sense.+data Aspect =+    Timeout Dice.Dice  -- ^ specifies the cooldown before an item may be+                       --   applied again; if a copy of an item is applied+                       --   manually (not via periodic activation),+                       --   all effects on a single copy of the item are+                       --   disabled until the copy recharges for the given+                       --   time expressed in game turns; all copies+                       --   recharge concurrently+  | AddSkill Ability.Skill Dice.Dice+                       -- ^ bonus to a skill; in content, avoid boosting+                       --   skills such as SkApply via permanent equipment,+                       --   to avoid micromanagement through swapping items+                       --   among party members before each skill use+  | SetFlag Ability.Flag+                       -- ^ item feature+  | ELabel Text        -- ^ extra label of the item; it's not pluralized+  | ToThrow ThrowMod   -- ^ parameters modifying a throw+  | PresentAs (GroupName ItemKind)+                       -- ^ until identified, presents as this unique kind+  | EqpSlot Ability.EqpSlot+                       -- ^ AI and UI flag that leaks item intended use+  | Odds Dice.Dice [Aspect] [Aspect]+                       -- ^ if level-scaled dice roll > 50,+                       --   pick the former aspects, otherwise the latter+  deriving (Show, Eq)++-- | Effects of items. Can be invoked by the item wielder to affect+-- another actor or the wielder himself.+--+-- Various effects of an item kind are all groupped in one list,+-- at the cost of conditionals, sequences, etc., to ensure brevity+-- and simplicity of content definitions. Most effects fire regardless+-- of activation kind (the only exceptions are @OnSmash@ and @OnCombine@+-- effects) so the deviations, handled via the conditionals, are rare+-- and the definitions remain simple. Whether an item can be activated+-- in any particular way, OTOH, is specified via simple flags elsewhere,+-- again, by default, assuming that most activations are possible for all.+data Effect =+    Burn Dice.Dice     -- ^ burn with this damage+  | Explode (GroupName ItemKind)+                       -- ^ explode producing this group of blasts+  | RefillHP Int       -- ^ modify HP of the actor by this amount+  | RefillCalm Int     -- ^ modify Calm of the actor by this amount+  | Dominate           -- ^ change actor's allegiance+  | Impress            -- ^ make actor susceptible to domination+  | PutToSleep         -- ^ put actor to sleep, also calming him+  | Yell               -- ^ make the actor yell/yawn, waking him and others up+  | Summon (GroupName ItemKind) Dice.Dice+      -- ^ summon the given number of actors of this group+  | Ascend Bool           -- ^ ascend to another level of the dungeon+  | Escape                -- ^ escape from the dungeon+  | Paralyze Dice.Dice    -- ^ paralyze for this many game clips+  | ParalyzeInWater Dice.Dice+                          -- ^ paralyze for this many game clips due to water+  | InsertMove Dice.Dice  -- ^ give actor this many extra tenths of actor move+  | Teleport Dice.Dice    -- ^ teleport actor across rougly this distance+  | CreateItem (Maybe Int) CStore (GroupName ItemKind) TimerDice+      -- ^ create an item of the group and insert into the store with the given+      --   random timer; it cardinality not specified, roll it+  | DestroyItem Int Int CStore (GroupName ItemKind)+      -- ^ destroy some items of the group from the store; see below about Ints+  | ConsumeItems [(Int, GroupName ItemKind)] [(Int, GroupName ItemKind)]+      -- ^ @ConsumeItems toUse toDestroy@ uses items matching @toUse@+      --   (destroys non-durable, without invoking OnSmash effects;+      --   applies normal effects of durable, without destroying them;+      --   the same behaviour as when transforming terrain using items)+      --   and destroys items matching @toDestroy@, invoking no effects,+      --   regardless of durability;+      --   the items are taken from @CGround@ (but not from @CEqp@),+      --   preferring non-durable (since durable can harm when used+      --   and may be more vauable when destroyed); if not all required items+      --   are present, no item are destroyed; if an item belongs to many groups+      --   in the sum of @toUse@ and @toDestroy@, it counts for all+      --   (otherwise, some orders of destroying would succeed,+      --   while others would not); even if item durable, as many copies+      --   are needed as specified, not just one applied many times;+      --   items are first destroyed and then, if any copies left, applied+  | DropItem Int Int CStore (GroupName ItemKind)+      -- ^ make the actor drop items of the given group from the given store;+      --   the first integer says how many item kinds to drop, the second,+      --   how many copies of each kind to drop;+      --   for non-organs, beware of not dropping all kinds, or cluttering+      --   store with rubbish becomes beneficial+  | Recharge Int Dice.Dice+      -- ^ reduce the cooldown period of this number of discharged items+      --   in the victim's equipment and organs by this dice of game clips;+      --   if the result is negative, set to 0, instantly recharging the item;+      --   starts with weapons with highest raw damage in equipment,+      --   then among organs, then non-weapons in equipment and among organs;+      --   beware of exploiting for healing periodic items+  | Discharge Int Dice.Dice+      -- ^ increase the cooldown period of this number of fully recharged items+      --   in the victim's equipment and organs by this dice of game clips;+      --   starts with weapons with highest raw damage in equipment,+      --   then among organs, then non-weapons in equipment and among organs;+      --   beware of exploiting for hunger inducing and similar organs+  | PolyItem+      -- ^ get a suitable (i.e., numerous enough) non-unique common item stack+      --   on the floor and polymorph it to a stack of random common items,+      --   with current depth coefficient+  | RerollItem+      -- ^ get a suitable (i.e., with any random aspects) single item+      --   (even unique) on the floor and change the random bonuses+      --   of the items randomly, with maximal depth coefficient+  | DupItem+      -- ^ exactly duplicate a single non-unique, non-valuable item on the floor+  | Identify+      -- ^ find a suitable (i.e., not identified) item, starting from+      --   the floor, and identify it+  | Detect DetectKind Int -- ^ detect something on the map in the given radius+  | SendFlying ThrowMod   -- ^ send an actor flying (push or pull, depending)+  | PushActor ThrowMod    -- ^ push an actor+  | PullActor ThrowMod    -- ^ pull an actor+  | ApplyPerfume          -- ^ remove all smell on the level+  | AtMostOneOf [Effect]  -- ^ try to trigger a single random effect of the list+  | OneOf [Effect]        -- ^ trigger, with equal probability,+                          --   one of the effects that don't end with @UseDud@+  | OnSmash Effect+      -- ^ trigger the effect when item smashed (not when applied nor meleed)+  | OnCombine Effect+      -- ^ trigger the effect only when the actor explicitly desires+      --   to combine items or otherwise subtly tinker with an+      --   item or a tile, e.g., craft items from other items in a workshop;+      --   in particular, don't trigger the effects when entering a tile;+      --   trigger exclusively the effects when activating walkable terrain+  | OnUser Effect  -- ^ apply the effect to the user, not the victim+  | NopEffect                -- ^ nothing happens, @UseDud@, no description+  | AndEffect Effect Effect  -- ^ only fire second effect if first activated+  | OrEffect Effect Effect   -- ^ only fire second effect if first not activated+  | SeqEffect [Effect]       -- ^ fire all effects in order; always suceed+  | When Condition Effect    -- ^ if condition not met, fail without a message;+                             --   better avoided, since AI can't value it well+  | Unless Condition Effect  -- ^ if condition met, fail without a message;+                             --   better avoided, since AI can't value it well+  | IfThenElse Condition Effect Effect+                             -- ^ conditional effect;+                             --   better avoided, since AI can't value it well+  | VerbNoLonger Text Text+      -- ^ a sentence with the actor causing the effect as subject, the given+      --   texts as the verb and the ending of the sentence (that may be+      --   ignored when the message is cited, e.g., as heard by someone)+      --   that is emitted when an activation causes an item to expire;+      --   no spam is emitted if a projectile; the ending is appended+      --   without a space in-between+  | VerbMsg Text Text+      -- ^ as @VerbNoLonger@ but that is emitted whenever the item is activated;+  | VerbMsgFail Text Text+      -- ^ as @VerbMsg@, but a failed effect (returns @UseId@)+  deriving (Show, Eq)++data Condition =+    HpLeq Int+  | HpGeq Int+  | CalmLeq Int+  | CalmGeq Int+  | TriggeredBy Ability.ActivationFlag+  deriving (Show, Eq)++data DetectKind =+    DetectAll+  | DetectActor+  | DetectLoot+  | DetectExit+  | DetectHidden+  | DetectEmbed+  | DetectStash+  deriving (Show, Eq)++-- | Specification of how to randomly roll a timer at item creation+-- to obtain a fixed timer for the item's lifetime.+data TimerDice =+    TimerNone+  | TimerGameTurn Dice.Dice+  | TimerActorTurn Dice.Dice+  deriving Eq++instance Show TimerDice where+  show TimerNone = "0"+  show (TimerGameTurn nDm) =+    show nDm ++ " " ++ if nDm == 1 then "turn" else "turns"+  show (TimerActorTurn nDm) =+    show nDm ++ " " ++ if nDm == 1 then "move" else "moves"++-- | Parameters modifying a throw of a projectile or flight of pushed actor.+-- Not additive and don't start at 0.+data ThrowMod = ThrowMod+  { throwVelocity :: Int  -- ^ fly with this percentage of base throw speed+  , throwLinger   :: Int  -- ^ fly for this percentage of 2 turns+  , throwHP       :: Int  -- ^ start flight with this many HP+  }+  deriving (Show, Eq, Ord, Generic)++instance Binary ThrowMod++instance Hashable ThrowMod++data ItemSymbolsUsedInEngine = ItemSymbolsUsedInEngine+  { rsymbolProjectile :: ContentSymbol ItemKind+  , rsymbolLight      :: ContentSymbol ItemKind+  , rsymbolTool       :: ContentSymbol ItemKind+  , rsymbolSpecial    :: ContentSymbol ItemKind+  , rsymbolGold       :: ContentSymbol ItemKind+  , rsymbolNecklace   :: ContentSymbol ItemKind+  , rsymbolRing       :: ContentSymbol ItemKind+  , rsymbolPotion     :: ContentSymbol ItemKind+  , rsymbolFlask      :: ContentSymbol ItemKind+  , rsymbolScroll     :: ContentSymbol ItemKind+  , rsymbolTorsoArmor :: ContentSymbol ItemKind+  , rsymbolMiscArmor  :: ContentSymbol ItemKind+  , rsymbolClothes    :: ContentSymbol ItemKind+  , rsymbolShield     :: ContentSymbol ItemKind+  , rsymbolPolearm    :: ContentSymbol ItemKind+  , rsymbolEdged      :: ContentSymbol ItemKind+  , rsymbolHafted     :: ContentSymbol ItemKind+  , rsymbolWand       :: ContentSymbol ItemKind+  , rsymbolFood       :: ContentSymbol ItemKind+  }++emptyItemSymbolsUsedInEngine :: ItemSymbolsUsedInEngine+emptyItemSymbolsUsedInEngine = ItemSymbolsUsedInEngine+  { rsymbolProjectile = toContentSymbol '0'+  , rsymbolLight      = toContentSymbol '0'+  , rsymbolTool       = toContentSymbol '0'+  , rsymbolSpecial    = toContentSymbol '0'+  , rsymbolGold       = toContentSymbol '0'+  , rsymbolNecklace   = toContentSymbol '0'+  , rsymbolRing       = toContentSymbol '0'+  , rsymbolPotion     = toContentSymbol '0'+  , rsymbolFlask      = toContentSymbol '0'+  , rsymbolScroll     = toContentSymbol '0'+  , rsymbolTorsoArmor = toContentSymbol '0'+  , rsymbolMiscArmor  = toContentSymbol '0'+  , rsymbolClothes    = toContentSymbol '0'+  , rsymbolShield     = toContentSymbol '0'+  , rsymbolPolearm    = toContentSymbol '0'+  , rsymbolEdged      = toContentSymbol '0'+  , rsymbolHafted     = toContentSymbol '0'+  , rsymbolWand       = toContentSymbol '0'+  , rsymbolFood       = toContentSymbol '0'+  }++boostItemKindList :: SM.SMGen -> [ItemKind] -> [ItemKind]+boostItemKindList _ [] = []+boostItemKindList initialGen l =+  let (r, _) = nextRandom (length l - 1) initialGen+  in case splitAt r l of+    (pre, i : post) -> pre ++ boostItemKind i : post+    _               -> error $ "" `showFailure` l++boostItemKind :: ItemKind -> ItemKind+boostItemKind i =+  let mainlineLabel (label, _) =+        label `elem` [COMMON_ITEM, CRAWL_ITEM, TREASURE]+  in if any mainlineLabel (ifreq i)+     then i { ifreq = (COMMON_ITEM, 10000) : filter (not . mainlineLabel)+                                                    (ifreq i)+            , iaspects = delete (SetFlag Ability.Unique) $ iaspects i+            }+     else i++-- | Whether the effect has a chance of exhibiting any potentially+-- noticeable behaviour, except when the item is destroyed or combined.+-- We assume at least one of @OneOf@ effects must be noticeable.+forApplyEffect :: Effect -> Bool+forApplyEffect eff = case eff of+  OnSmash{} -> False+  OnCombine{} -> False+  OnUser eff1 -> forApplyEffect eff1+  NopEffect -> False+  AndEffect eff1 eff2 -> forApplyEffect eff1 || forApplyEffect eff2+  OrEffect eff1 eff2 -> forApplyEffect eff1 || forApplyEffect eff2+  SeqEffect effs -> any forApplyEffect effs+  When _ eff1 -> forApplyEffect eff1+  Unless _ eff1 -> forApplyEffect eff1+  IfThenElse _ eff1 eff2 -> forApplyEffect eff1 || forApplyEffect eff2+  VerbNoLonger{} -> False+  VerbMsg{} -> False+  VerbMsgFail{} -> False+  ParalyzeInWater{} -> False  -- barely noticeable, spams when resisted+  _ -> True++-- | Whether a non-nested effect always applies raw damage.+forDamageEffect :: Effect -> Bool+forDamageEffect eff = case eff of+  Burn{} -> True+  RefillHP n | n < 0 -> True+  _ -> False++-- | Whether an item is damaging. Such items may trigger embedded items+-- and may collide with bursting items mid-air.+isDamagingKind :: ItemKind -> Bool+isDamagingKind itemKind = Dice.infDice (idamage itemKind) > 0+                          || any forDamageEffect (ieffects itemKind)++isEffEscape :: Effect -> Bool+isEffEscape Escape{} = True+isEffEscape (AtMostOneOf l) = any isEffEscape l+isEffEscape (OneOf l) = any isEffEscape l+isEffEscape (OnCombine eff) = isEffEscape eff+isEffEscape (OnUser eff) = isEffEscape eff+isEffEscape (AndEffect eff1 eff2) = isEffEscape eff1 || isEffEscape eff2+isEffEscape (OrEffect eff1 eff2) = isEffEscape eff1 || isEffEscape eff2+isEffEscape (SeqEffect effs) = any isEffEscape effs+isEffEscape (When _ eff) = isEffEscape eff+isEffEscape (Unless _ eff) = isEffEscape eff+isEffEscape (IfThenElse _ eff1 eff2) = isEffEscape eff1 || isEffEscape eff2+isEffEscape _ = False++isEffEscapeOrAscend :: Effect -> Bool+isEffEscapeOrAscend Ascend{} = True+isEffEscapeOrAscend Escape{} = True+isEffEscapeOrAscend (AtMostOneOf l) = any isEffEscapeOrAscend l+isEffEscapeOrAscend (OneOf l) = any isEffEscapeOrAscend l+isEffEscapeOrAscend (OnCombine eff) = isEffEscapeOrAscend eff+isEffEscapeOrAscend (OnUser eff) = isEffEscapeOrAscend eff+isEffEscapeOrAscend (AndEffect eff1 eff2) =+  isEffEscapeOrAscend eff1 || isEffEscapeOrAscend eff2+isEffEscapeOrAscend (OrEffect eff1 eff2) =+  isEffEscapeOrAscend eff1 || isEffEscapeOrAscend eff2+isEffEscapeOrAscend (SeqEffect effs) =+  any isEffEscapeOrAscend effs+isEffEscapeOrAscend (When _ eff) = isEffEscapeOrAscend eff+isEffEscapeOrAscend (Unless _ eff) = isEffEscapeOrAscend eff+isEffEscapeOrAscend (IfThenElse _ eff1 eff2) =+  isEffEscapeOrAscend eff1 || isEffEscapeOrAscend eff2+isEffEscapeOrAscend _ = False++timeoutAspect :: Aspect -> Bool+timeoutAspect Timeout{} = True+timeoutAspect _ = False++orEffect :: Effect -> Bool+orEffect OrEffect{} = True+orEffect _ = False++onSmashEffect :: Effect -> Bool+onSmashEffect OnSmash{} = True+onSmashEffect _ = False++onCombineEffect :: Effect -> Bool+onCombineEffect OnCombine{} = True+onCombineEffect _ = False++onSmashOrCombineEffect :: Effect -> Bool+onSmashOrCombineEffect OnSmash{} = True+onSmashOrCombineEffect OnCombine{} = True+onSmashOrCombineEffect _ = False++alwaysDudEffect :: Effect -> Bool+alwaysDudEffect OnSmash{} = True+alwaysDudEffect OnCombine{} = True+alwaysDudEffect NopEffect = True+alwaysDudEffect _ = False++strengthOnSmash :: ItemKind -> [Effect]+strengthOnSmash =+  let f (OnSmash eff) = [eff]+      f _ = []+  in concatMap f . ieffects++strengthOnCombine :: ItemKind -> [Effect]+strengthOnCombine =+  let f (OnCombine eff) = [eff]+      f _ = []+  in concatMap f . ieffects++getDropOrgans :: ItemKind -> [GroupName ItemKind]+getDropOrgans =+  let f (DestroyItem _ _ COrgan grp) = [grp]+      f (DropItem _ _ COrgan grp) = [grp]+      f Impress = [S_IMPRESSED]+      f (AtMostOneOf l) = concatMap f l  -- even remote possibility accepted+      f (OneOf l) = concatMap f l  -- even remote possibility accepted+      f (OnUser eff) = f eff  -- no OnCombine, because checked for potions, etc.+      f (AndEffect eff1 eff2) = f eff1 ++ f eff2  -- not certain, but accepted+      f (OrEffect eff1 eff2) = f eff1 ++ f eff2  -- not certain, but accepted+      f (SeqEffect effs) = concatMap f effs+      f (When _ eff) = f eff+      f (Unless _ eff) = f eff+      f (IfThenElse _ eff1 eff2) = f eff1 ++ f eff2+      f _ = []+  in concatMap f . ieffects++-- Anything under @Odds@ is ignored, because it's not mandatory.+getMandatoryPresentAsFromKind :: ItemKind -> Maybe (GroupName ItemKind)+getMandatoryPresentAsFromKind itemKind =+  let f (PresentAs grp) = [grp]+      f _ = []+  in listToMaybe $ concatMap f (iaspects itemKind)++damageUsefulness :: ItemKind -> Double+damageUsefulness itemKind =+  let v = min 1000 (10 * Dice.meanDice (idamage itemKind))+  in assert (v >= 0) v++verbMsgNoLonger :: Text -> Effect+verbMsgNoLonger name = VerbNoLonger ("be no longer" <+> name) "."++verbMsgLess :: Text -> Effect+verbMsgLess name = VerbMsg ("appear less" <+> name) "."++toVelocity :: Int -> Aspect+toVelocity n = ToThrow $ ThrowMod n 100 1++toLinger :: Int -> Aspect+toLinger n = ToThrow $ ThrowMod 100 n 1++timerNone :: TimerDice+timerNone = TimerNone++isTimerNone :: TimerDice -> Bool+isTimerNone tim = tim == TimerNone++foldTimer :: a -> (Dice.Dice -> a) -> (Dice.Dice -> a) -> TimerDice -> a+foldTimer a fgame factor tim = case tim of+  TimerNone -> a+  TimerGameTurn nDm -> fgame nDm+  TimerActorTurn nDm -> factor nDm++toOrganBad :: GroupName ItemKind -> Dice.Dice -> Effect+toOrganBad grp nDm = CreateItem Nothing COrgan grp (TimerGameTurn nDm)++toOrganGood :: GroupName ItemKind -> Dice.Dice -> Effect+toOrganGood grp nDm = CreateItem Nothing COrgan grp (TimerActorTurn nDm)++toOrganNoTimer :: GroupName ItemKind -> Effect+toOrganNoTimer grp = CreateItem Nothing COrgan grp TimerNone++-- | Catch invalid item kind definitions.+validateSingle :: ItemSymbolsUsedInEngine -> ItemKind -> [Text]+validateSingle itemSymbols ik@ItemKind{..} =+  ["iname longer than 23" | T.length iname > 23]+  ++ ["icount < 0" | Dice.infDice icount < 0]+  ++ validateRarity irarity+  ++ validateDamage idamage+  -- Reject duplicate Timeout, because it's not additive.+  ++ (let ts = filter timeoutAspect iaspects+      in ["more than one Timeout specification" | length ts > 1])+  ++ [ "Conflicting Fragile and Durable"+     | SetFlag Ability.Fragile `elem` iaspects+       && SetFlag Ability.Durable `elem` iaspects ]+  ++ (let f :: Aspect -> Bool+          f EqpSlot{} = True+          f _ = False+          ts = filter f iaspects+          equipable = SetFlag Ability.Equipable `elem` iaspects+          meleeable = SetFlag Ability.Meleeable `elem` iaspects+          likelyTemplate = case ifreq of+            [(grp, 1)] -> "unknown" `T.isSuffixOf` fromGroupName grp+            _ -> False+          likelyException = isymbol `elem` [ rsymbolFood itemSymbols+                                           , rsymbolNecklace itemSymbols+                                           , rsymbolWand itemSymbols ]+                            || likelyTemplate+      in [ "EqpSlot specified but not Equipable nor Meleeable"+         | length ts == 1 && not equipable && not meleeable ]+         ++ [ "EqpSlot not specified but Equipable or Meleeable and not a likely organ or necklace or template"+            | not likelyException+              && null ts && (equipable || meleeable) ]+         ++ [ "More than one EqpSlot specified"+            | length ts > 1 ] )+  ++ [ "Redundant Equipable or Meleeable"+     | SetFlag Ability.Equipable `elem` iaspects+       && SetFlag Ability.Meleeable `elem` iaspects ]+  ++ [ "Conflicting Durable and Blast"+     | SetFlag Ability.Durable `elem` iaspects+       && SetFlag Ability.Blast `elem` iaspects ]+  ++ [ "Conflicting Durable and Condition"+     | SetFlag Ability.Durable `elem` iaspects+       && SetFlag Ability.Condition `elem` iaspects ]+  ++ [ "Conflicting Blast and Condition"+     | SetFlag Ability.Blast `elem` iaspects+       && SetFlag Ability.Condition `elem` iaspects ]+  ++ (let f :: Aspect -> Bool+          f ELabel{} = True+          f _ = False+          ts = filter f iaspects+      in ["more than one ELabel specification" | length ts > 1])+  ++ (let f :: Aspect -> Bool+          f ToThrow{} = True+          f _ = False+          ts = filter f iaspects+      in ["more than one ToThrow specification" | length ts > 1])+  ++ (let f :: Aspect -> Bool+          f PresentAs{} = True+          f _ = False+          ts = filter f iaspects+      in ["more than one PresentAs specification" | length ts > 1])+  ++ concatMap (validateDups ik . SetFlag) [minBound .. maxBound]+  ++ (let f :: Effect -> Bool+          f VerbNoLonger{} = True+          f _ = False+      in validateOnlyOne ieffects "VerbNoLonger" f)  -- may be duped if nested+  ++ (let f :: Effect -> Bool+          f VerbMsg{} = True+          f _ = False+      in validateOnlyOne ieffects "VerbMsg" f)  -- may be duplicated if nested+  ++ (let f :: Effect -> Bool+          f VerbMsgFail{} = True+          f _ = False+      in validateOnlyOne ieffects "VerbMsgFail" f)  -- may be duped if nested+  ++ validateNotNested ieffects "OnSmash or OnCombine" onSmashOrCombineEffect+       -- but duplicates permitted+  ++ let nonPositiveBurn :: Effect -> Bool+         nonPositiveBurn (Burn d) = Dice.infDice d <= 0+         nonPositiveBurn _ = False+         containingNonPositiveBurn =+           filter (checkSubEffectProp nonPositiveBurn) ieffects+     in [ "effects with non-positive Burn:" <+> tshow containingNonPositiveBurn+        | not $ null containingNonPositiveBurn ]+  ++ let emptyOneOf :: Effect -> Bool+         emptyOneOf (AtMostOneOf []) = True+         emptyOneOf (OneOf []) = True+         emptyOneOf _ = False+         containingEmptyOneOf = filter (checkSubEffectProp emptyOneOf) ieffects+     in [ "effects with empty AtMostOneOf or OneOf:"+          <+> tshow containingEmptyOneOf+        | not $ null containingEmptyOneOf ]+  ++ (let nonPositiveEffect :: Effect -> Bool+          nonPositiveEffect (CreateItem (Just n) _ _ _) | n <= 0 = True+          nonPositiveEffect (DestroyItem n k _ _) | n <= 0 || k <= 0 = True+          nonPositiveEffect (ConsumeItems tools raw)+            | any ((<= 0) . fst) (tools ++ raw) = True+          nonPositiveEffect (DropItem n k _ _) | n <= 0 || k <= 0 = True+          nonPositiveEffect (Detect _ n) | n <= 0 = True+          nonPositiveEffect _ = False+          containingNonPositiveEffect =+            filter (checkSubEffectProp nonPositiveEffect) ieffects+      in [ "effects with forbidden non-positive parameters:"+           <+> tshow containingNonPositiveEffect+         | not $ null containingNonPositiveEffect ])+  ++ (let nonPositiveEffect :: Effect -> Bool+          nonPositiveEffect (Summon _ d) | Dice.infDice d <= 0 = True+          nonPositiveEffect (Paralyze d) | Dice.infDice d <= 0 = True+          nonPositiveEffect (ParalyzeInWater d) | Dice.infDice d <= 0 = True+          nonPositiveEffect (InsertMove d) | Dice.infDice d <= 0 = True+          nonPositiveEffect (Teleport d) | Dice.infDice d <= 0 = True+          nonPositiveEffect (CreateItem _ _ _ (TimerGameTurn d))+            | Dice.infDice d <= 0 = True+          nonPositiveEffect (CreateItem _ _ _ (TimerActorTurn d))+            | Dice.infDice d <= 0 = True+          nonPositiveEffect (Recharge n d)+            | n <= 0 || Dice.infDice d <= 0 = True+          nonPositiveEffect (Discharge n d)+            | n <= 0 || Dice.infDice d <= 0 = True+          nonPositiveEffect _ = False+          containingNonPositiveEffect =+            filter (checkSubEffectProp nonPositiveEffect) ieffects+      in [ "effects with forbidden potentially non-positive or negative number or dice:"+           <+> tshow containingNonPositiveEffect+         | not $ null containingNonPositiveEffect ])++-- We only check there are no duplicates at top level. If it may be nested,+-- it may presumably be duplicated inside the nesting as well.+validateOnlyOne :: [Effect] -> Text -> (Effect -> Bool) -> [Text]+validateOnlyOne effs t f =+  let ts = filter f effs+  in ["more than one" <+> t <+> "specification" | length ts > 1]++-- We check it's not nested one nor more levels.+validateNotNested :: [Effect] -> Text -> (Effect -> Bool) -> [Text]+validateNotNested effs t f =+  let g (AtMostOneOf l) = any h l+      g (OneOf l) = any h l+      g (OnSmash effect) = h effect+      g (OnCombine effect) = h effect+      g (OnUser effect) = h effect+      g (AndEffect eff1 eff2) = h eff1 || h eff2+      g (OrEffect eff1 eff2) = h eff1 || h eff2+      g (SeqEffect effs2) = any h effs2+      g (When _ effect) = h effect+      g (Unless _ effect) = h effect+      g (IfThenElse _ eff1 eff2) = h eff1 || h eff2+      g _ = False+      h effect = f effect || g effect+      ts = filter g effs+  in [ "effect" <+> t <+> "should be specified at top level, not nested"+     | not (null ts) ]++checkSubEffectProp :: (Effect -> Bool) -> Effect -> Bool+checkSubEffectProp f eff =+  let g (AtMostOneOf l) = any h l+      g (OneOf l) = any h l+      g (OnSmash effect) = h effect+      g (OnCombine effect) = h effect+      g (OnUser effect) = h effect+      g (AndEffect eff1 eff2) = h eff1 || h eff2+      g (OrEffect eff1 eff2) = h eff1 || h eff2+      g (SeqEffect effs) = any h effs+      g (When _ effect) = h effect+      g (Unless _ effect) = h effect+      g (IfThenElse _ eff1 eff2) = h eff1 || h eff2+      g _ = False+      h effect = f effect || g effect+  in h eff++validateDups :: ItemKind -> Aspect -> [Text]+validateDups ItemKind{..} feat =+  let ts = filter (== feat) iaspects+  in ["more than one" <+> tshow feat <+> "specification" | length ts > 1]++validateDamage :: Dice.Dice -> [Text]+validateDamage dice = [ "potentially negative dice:" <+> tshow dice+                      | Dice.infDice dice < 0]++-- | Validate all item kinds.+validateAll :: [ItemKind] -> ContentData ItemKind -> [Text]+validateAll content coitem =+  let f :: Aspect -> Bool+      f PresentAs{} = True+      f _ = False+      wrongPresentAsGroups =+        [ cgroup+        | k <- content+        , let (cgroup, notSingleton) = case find f (iaspects k) of+                Just (PresentAs grp) | not $ oisSingletonGroup coitem grp ->+                  (grp, True)+                _ -> (undefined, False)+        , notSingleton+        ]+  in [ "PresentAs groups not singletons:" <+> tshow wrongPresentAsGroups+     | not $ null wrongPresentAsGroups ]++makeData :: ItemSymbolsUsedInEngine+         -> [ItemKind] -> [GroupName ItemKind] -> [GroupName ItemKind]+         -> ContentData ItemKind+makeData itemSymbols content groupNamesSingleton groupNames =+  let allGroupNamesTooLong = filter ((> 23) . T.length . fromGroupName)+                             $ groupNamesSingleton ++ groupNames+  in assert (null allGroupNamesTooLong+             `blame` "ItemKind: some item group names too long"+             `swith` allGroupNamesTooLong) $+     makeContentData "ItemKind" iname ifreq+                     (validateSingle itemSymbols) validateAll content+                     (mandatoryGroupsSingleton ++ groupNamesSingleton)+                     (mandatoryGroups ++ groupNames)
+ definition-src/Game/LambdaHack/Content/ModeKind.hs view
@@ -0,0 +1,134 @@+-- | The type of game modes.+module Game.LambdaHack.Content.ModeKind+  ( pattern CAMPAIGN_SCENARIO, pattern INSERT_COIN+  , ModeKind(..), makeData+  , Caves, Roster+  , mandatoryGroups+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , validateSingle, validateAll, validateSingleRoster+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Text as T++import           Game.LambdaHack.Content.CaveKind (CaveKind)+import           Game.LambdaHack.Content.FactionKind+  (FactionKind (..), Outcome (..))+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Definition.ContentData+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.DefsInternal++-- | Game mode specification.+data ModeKind = ModeKind+  { mname     :: Text            -- ^ short description+  , mfreq     :: Freqs ModeKind  -- ^ frequency within groups+  , mtutorial :: Bool            -- ^ whether to show tutorial messages, etc.+  , mattract  :: Bool            -- ^ whether this is an attract mode+  , mroster   :: Roster          -- ^ factions taking part in the game+  , mcaves    :: Caves           -- ^ arena of the game+  , mendMsg   :: [(Outcome, Text)]+      -- ^ messages displayed at each particular game ends; if message empty,+      --   the screen is skipped+  , mrules    :: Text            -- ^ rules note+  , mdesc     :: Text            -- ^ description+  , mreason   :: Text            -- ^ why/when the mode should be played+  , mhint     :: Text            -- ^ hints in case player faces difficulties+  }+  deriving Show++-- | Requested cave groups for particular level intervals.+type Caves = [([Int], [GroupName CaveKind])]++-- | The specification of factions and of levels, numbers and groups+-- of their initial members.+type Roster = [( GroupName FactionKind+               , [(Int, Dice.Dice, GroupName ItemKind)] )]++-- | Catch invalid game mode kind definitions.+validateSingle :: ContentData FactionKind -> ModeKind -> [Text]+validateSingle cofact ModeKind{..} =+  [ "mname longer than 22" | T.length mname > 22 ]+  ++ let f cave@(ns, l) =+           [ "not enough or too many levels for required cave groups:"+             <+> tshow cave+           | length ns /= length l ]+     in concatMap f mcaves+  ++ validateSingleRoster cofact mcaves mroster++-- | Checks, in particular, that there is at least one faction with fneverEmpty+-- or the game would get stuck as soon as the dungeon is devoid of actors.+validateSingleRoster :: ContentData FactionKind -> Caves -> Roster -> [Text]+validateSingleRoster cofact caves roster =+  let emptyGroups = filter (not . oexistsGroup cofact) $ map fst roster+  in [ "the following faction kind groups have no representative with non-zero frequency:"+       <+> T.intercalate ", " (map displayGroupName emptyGroups)+     | not $ null emptyGroups ]+  ++ let fkKeepsAlive acc _ _ fk = acc && fneverEmpty fk+           -- all of group elements have to keep level alive, hence conjunction+         fkGroupKeepsAlive (fkGroup, _) =+           ofoldlGroup' cofact fkGroup fkKeepsAlive True+     in [ "potentially no faction keeps the dungeon alive"+        | not $ any fkGroupKeepsAlive roster ]+  ++ let fkHasUIor acc _ _ fk = acc || fhasUI fk+           -- single group element having UI already incurs the risk+           -- of duplication, hence disjunction+         fkGroupHasUIor (fkGroup, _) =+           ofoldlGroup' cofact fkGroup fkHasUIor False+     in [ "potentially more than one UI client"+        | length (filter fkGroupHasUIor roster) > 1 ]+  ++ let fkHasUIand acc _ _ fk = acc && fhasUI fk+           -- single group element missing UI already incurs the risk+           -- of no UI in the whole game, hence disjunction+         fkGroupHasUIand (fkGroup, _) =+           ofoldlGroup' cofact fkGroup fkHasUIand True+     in [ "potentially less than one UI client"+        | not (any fkGroupHasUIand roster) ]+  ++ let fkTokens acc _ _ fk = fteam fk : acc+         fkGroupTokens (fkGroup, _) = ofoldlGroup' cofact fkGroup fkTokens []+         tokens = concatMap (nub . sort . fkGroupTokens) roster+         nubTokens = nub . sort $ tokens+     in [ "potentially duplicate team continuity token"+        | length tokens /= length nubTokens ]+  ++ let keys = concatMap fst caves  -- permitted to be empty, for tests+         minD = minimum keys+         maxD = maximum keys+         f (_, l) = concatMap g l+         g i3@(ln, _, _) =+           [ "initial actor levels not among caves:" <+> tshow i3+           | ln `notElem` keys ]+     in concatMap f roster+        ++ [ "player is confused by both positive and negative level numbers"+           | not (null keys) && signum minD /= signum maxD ]+        ++ [ "player is confused by level numer zero"+           | 0 `elem` keys ]++-- | Validate game mode kinds together.+validateAll :: [ModeKind] -> ContentData ModeKind -> [Text]+validateAll _ _ = []  -- so far, always valid++-- * Mandatory item groups++mandatoryGroups :: [GroupName ModeKind]+mandatoryGroups =+       [CAMPAIGN_SCENARIO, INSERT_COIN]++pattern CAMPAIGN_SCENARIO, INSERT_COIN :: GroupName ModeKind++pattern CAMPAIGN_SCENARIO = GroupName "campaign scenario"+pattern INSERT_COIN = GroupName "insert coin"++makeData :: ContentData FactionKind+         -> [ModeKind] -> [GroupName ModeKind] -> [GroupName ModeKind]+         -> ContentData ModeKind+makeData cofact content groupNamesSingleton groupNames =+  makeContentData "ModeKind" mname mfreq (validateSingle cofact) validateAll+                  content+                  groupNamesSingleton+                  (mandatoryGroups ++ groupNames)
+ definition-src/Game/LambdaHack/Content/PlaceKind.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DeriveGeneric #-}+-- | The type of place kinds. Every room in the game is an instantiated+-- place kind.+module Game.LambdaHack.Content.PlaceKind+  ( PlaceKind(..), makeData+  , Cover(..), Fence(..)+  , PlaceEntry(..), deadEndId, overridePlaceKind, override2PlaceKind+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , validateSingle, validateAll+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import           GHC.Generics (Generic)++import Game.LambdaHack.Content.TileKind (TileKind)+import Game.LambdaHack.Definition.ContentData+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal++-- | Parameters for the generation of small areas within a dungeon level.+data PlaceKind = PlaceKind+  { pname       :: Text          -- ^ short description, singular or plural+  , pfreq       :: Freqs PlaceKind  -- ^ frequency within groups+  , prarity     :: Rarity        -- ^ rarity on given depths+  , pcover      :: Cover         -- ^ how to fill whole place using the corner+  , pfence      :: Fence         -- ^ whether to fence place with solid border+  , ptopLeft    :: [Text]        -- ^ plan of the top-left corner of the place+  , plegendDark :: EM.EnumMap Char (GroupName TileKind)  -- ^ dark legend+  , plegendLit  :: EM.EnumMap Char (GroupName TileKind)  -- ^ lit legend+  }+  deriving Show  -- No Eq and Ord to make extending logically sound++-- | A method of filling the whole area (except for CVerbatim and CMirror,+-- which are just placed in the middle of the area) by transforming+-- a given corner.+data Cover =+    CAlternate  -- ^ reflect every other corner, overlapping 1 row and column+  | CStretch    -- ^ fill symmetrically 4 corners and stretch their borders+  | CReflect    -- ^ tile separately and symmetrically quarters of the place+  | CVerbatim   -- ^ just build the given interior, without filling the area+  | CMirror     -- ^ build the given interior in one of 4 mirrored variants+  deriving (Show, Eq)++-- | The choice of a fence type for the place.+data Fence =+    FWall   -- ^ put a solid wall fence around the place+  | FFloor  -- ^ leave an empty space, like the room's floor+  | FGround -- ^ leave an empty space, like the cave's ground+  | FNone   -- ^ skip the fence and fill all with the place proper+  deriving (Show, Eq)++-- | Places are rooms and other dungeon features, their names can be seen+-- on a level map by aiming at a position that is an entry to the place+-- (an individual entrance point, an approach area around the place+-- or a phantom entry not on the map, but only used for statistics+-- to witness the place exists). Entries are proxies for initial places+-- created on the level (which may be otherwise eradicated by burrowing+-- the walls, etc.) and so used for dungeon statistics.+-- The statistics are presented in the @Dashboard/displace place lore@ menu.+data PlaceEntry =+    PEntry (ContentId PlaceKind)+  | PAround (ContentId PlaceKind)+  | PExists (ContentId PlaceKind)+  deriving (Show, Eq, Generic)++instance Binary PlaceEntry++deadEndId :: ContentId PlaceKind+{-# INLINE deadEndId #-}+deadEndId = toContentId 0++overridePlaceKind :: [(Char, GroupName TileKind)] -> PlaceKind -> PlaceKind+overridePlaceKind l pk = pk+  { plegendDark = EM.fromList l `EM.union` plegendDark pk+  , plegendLit = EM.fromList l `EM.union` plegendLit pk }++override2PlaceKind :: [(Char, GroupName TileKind)]+                   -> [(Char, GroupName TileKind)]+                   -> PlaceKind+                   -> PlaceKind+override2PlaceKind lDark lLit pk = pk+  { plegendDark = EM.fromList lDark `EM.union` plegendDark pk+  , plegendLit = EM.fromList lLit `EM.union` plegendLit pk }++-- | Catch invalid place kind definitions. In particular, verify that+-- the top-left corner map is rectangular and not empty.+validateSingle :: ContentData TileKind -> PlaceKind -> [Text]+validateSingle cotile PlaceKind{..} =+  let dxcorner = case ptopLeft of+        [] -> 0+        l : _ -> T.length l+      inLegend :: Text -> EM.EnumMap Char (GroupName TileKind) -> Char -> [Text]+      inLegend _ _ 'X' = []  -- special placeholder symbol; TODO: unhardwire+      inLegend legendName m c = case EM.lookup c m of+        Nothing -> [tshow c <+> "tile code not found in" <+> legendName]+        Just grp -> [ tshow c <+> "tile code has group"+                      <+> displayGroupName grp+                      <+> "with null frequency in tile content"+                    | not $ oexistsGroup cotile grp ]+      inLegendAll legendName m = concatMap (inLegend legendName m)+                                           (concatMap T.unpack ptopLeft)+  in [ "top-left corner empty" | dxcorner == 0 ]+     ++ [ "top-left corner not rectangular"+        | any ((/= dxcorner) . T.length) ptopLeft ]+     ++ inLegendAll "plegendDark" plegendDark+     ++ inLegendAll "plegendLit" plegendLit+     ++ validateRarity prarity++-- | Validate all place kinds.+validateAll :: [PlaceKind] -> ContentData PlaceKind -> [Text]+validateAll _ _ = []  -- so far, always valid++makeData :: ContentData TileKind+         -> [PlaceKind] -> [GroupName PlaceKind] -> [GroupName PlaceKind]+         -> ContentData PlaceKind+makeData cotile = makeContentData "PlaceKind" pname pfreq+                                  (validateSingle cotile) validateAll
+ definition-src/Game/LambdaHack/Content/RuleKind.hs view
@@ -0,0 +1,73 @@+-- | The type of game rules and assorted game data.+module Game.LambdaHack.Content.RuleKind+  ( RuleContent(..), emptyRuleContent, makeData+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , emptyRuleContentRaw, validateSingle+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Ini as Ini+import qualified Data.Ini.Types as Ini+import           Data.Version++import Game.LambdaHack.Content.ItemKind+  (ItemSymbolsUsedInEngine, emptyItemSymbolsUsedInEngine)+import Game.LambdaHack.Definition.Defs++-- | The type of game rules and assorted game data.+data RuleContent = RuleContent+  { rtitle            :: String    -- ^ title of the game (not lib)+  , rWidthMax         :: X         -- ^ maximum level width+  , rHeightMax        :: Y         -- ^ maximum level height+  , rexeVersion       :: Version   -- ^ version of the game+  , rcfgUIName        :: FilePath  -- ^ name of the UI config file+  , rcfgUIDefault     :: (Text, Ini.Config)+                                   -- ^ the default UI settings config file+  , rwriteSaveClips   :: Int       -- ^ game saved that often (not on browser)+  , rleadLevelClips   :: Int       -- ^ server switches leader level that often+  , rscoresFileName   :: FilePath  -- ^ name of the scores file+  , rnearby           :: Int       -- ^ what is a close distance between actors+  , rstairWordCarried :: [Text]    -- ^ words that can't be dropped from stair+                                   --   name as it goes through levels+  , ritemSymbols      :: ItemSymbolsUsedInEngine+                                   -- ^ item symbols treated specially in engine+  }++emptyRuleContentRaw :: RuleContent+emptyRuleContentRaw = RuleContent+  { rtitle = ""+  , rWidthMax = 5+  , rHeightMax = 2+  , rexeVersion = makeVersion []+  , rcfgUIName = ""+  , rcfgUIDefault = ("", Ini.emptyConfig)+  , rwriteSaveClips = 0+  , rleadLevelClips = 0+  , rscoresFileName = ""+  , rnearby = 0+  , rstairWordCarried = []+  , ritemSymbols = emptyItemSymbolsUsedInEngine+  }++emptyRuleContent :: RuleContent+emptyRuleContent = assert (null $ validateSingle emptyRuleContentRaw)+                          emptyRuleContentRaw++-- | Catch invalid rule kind definitions.+validateSingle :: RuleContent -> [Text]+validateSingle RuleContent{..} =+  [ "rWidthMax < 5" | rWidthMax < 5 ]  -- indented (4 prop spaces) text+  ++ [ "rHeightMax < 2" | rHeightMax < 2 ]  -- or 4 tiles of sentinel wall++makeData :: RuleContent -> RuleContent+makeData rc =+  let singleOffenders = validateSingle rc+  in assert (null singleOffenders+             `blame` "Rule Content not valid"+             `swith` singleOffenders)+     rc
+ definition-src/Game/LambdaHack/Content/TileKind.hs view
@@ -0,0 +1,256 @@+-- | The type of tile kinds. Every terrain tile in the game is+-- an instantiated tile kind.+module Game.LambdaHack.Content.TileKind+  ( pattern S_UNKNOWN_SPACE, pattern S_UNKNOWN_OUTER_FENCE, pattern S_BASIC_OUTER_FENCE, pattern AQUATIC+  , TileKind(..), ProjectileTriggers(..), Feature(..)+  , makeData+  , isUknownSpace, unknownId+  , isSuspectKind, isOpenableKind, isClosableKind+  , talterForStairs, floorSymbol+  , mandatoryGroups, mandatoryGroupsSingleton+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , validateSingle, validateAll, validateDups+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Data.Word (Word8)++import Game.LambdaHack.Content.ItemKind (ItemKind)+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.ContentData+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal++-- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation+-- of the absence of a corresponding type @Tile@ that would hold+-- particular concrete tiles in the dungeon.+-- Note that tile names (and any other content names) should not be plural+-- (that would lead to "a stairs"), so "road with cobblestones" is fine,+-- but "granite cobblestones" is wrong.+--+-- Tile kind for unknown space has the minimal @ContentId@ index.+-- The @talter@ for unknown space is @1@ and no other tile kind has that value.+data TileKind = TileKind+  { tsymbol  :: Char         -- ^ map symbol+  , tname    :: Text         -- ^ short description+  , tfreq    :: Freqs TileKind  -- ^ frequency within groups+  , tcolor   :: Color        -- ^ map color+  , tcolor2  :: Color        -- ^ map color when not in FOV+  , talter   :: Word8        -- ^ minimal skill needed to activate embeds+                             --   and, in case of big actors not standing on+                             --   the tile, to alter the tile in any way+  , tfeature :: [Feature]    -- ^ properties; order matters+  }+  deriving Show  -- No Eq and Ord to make extending logically sound++-- | All possible terrain tile features.+data Feature =+    Embed (GroupName ItemKind)+      -- ^ initially an item of this group is embedded;+      --   we assume the item has effects and is supposed to be triggered+  | OpenTo (GroupName TileKind)+      -- ^ goes from a closed to closed or open tile when altered+  | CloseTo (GroupName TileKind)+      -- ^ goes from an open to open or closed tile when altered+  | ChangeTo (GroupName TileKind)+      -- ^ alters tile, but does not change walkability+  | OpenWith ProjectileTriggers+             [(Int, GroupName ItemKind)] (GroupName TileKind)+      -- ^ alters tile, as before, using up all listed items from the ground+      --   and equipment; the list never empty; for simplicity, such tiles+      --   are never taken into account when pathfinding+  | CloseWith ProjectileTriggers+              [(Int, GroupName ItemKind)] (GroupName TileKind)+  | ChangeWith ProjectileTriggers+               [(Int, GroupName ItemKind)] (GroupName TileKind)+  | HideAs (GroupName TileKind)+      -- ^ when hidden, looks as the unique tile of the group+  | BuildAs (GroupName TileKind)+      -- ^ when generating, may be transformed to the unique tile of the group+  | RevealAs (GroupName TileKind)+      -- ^ when generating in opening, can be revealed to belong to the group+  | ObscureAs (GroupName TileKind)+      -- ^ when generating in solid wall, can be revealed to belong to the group+  | Walkable             -- ^ actors can walk through+  | Clear                -- ^ actors can see through+  | Dark                 -- ^ is not lit with an ambient light+  | OftenItem            -- ^ initial items often generated there+  | VeryOftenItem        -- ^ initial items very often generated there+  | OftenActor           -- ^ initial actors often generated there;+                         --   counterpart of @VeryOftenItem@ for dark places+  | NoItem               -- ^ no items ever generated there+  | NoActor              -- ^ no actors ever generated there+  | ConsideredByAI       -- ^ even if otherwise uninteresting, taken into+                         --   account for triggering by AI+  | Trail                -- ^ used for visible trails throughout the level+  | Spice                -- ^ in place normal legend and in override,+                         --   don't roll a tile kind only once per place,+                         --   but roll for each position; one non-spicy+                         --   (according to frequencies of non-spicy) and+                         --   at most one spicy (according to their frequencies)+                         --   is rolled per place and then, once for each+                         --   position, one of the two is semi-randomly chosen+                         --   (according to their individual frequencies only)+  deriving (Show, Eq)++-- | Marks whether projectiles are permitted to trigger the tile transformation+-- action.+data ProjectileTriggers = ProjYes | ProjNo+  deriving (Show, Eq)++-- | Validate a single tile kind.+validateSingle :: TileKind -> [Text]+validateSingle t@TileKind{..} =+  [ "suspect tile is walkable" | Walkable `elem` tfeature+                                 && isSuspectKind t ]+  ++ [ "openable tile is open" | Walkable `elem` tfeature+                                 && isOpenableKind t ]+  ++ [ "closable tile is closed" | Walkable `notElem` tfeature+                                   && isClosableKind t ]+  ++ [ "walkable tile is considered for activating by AI"+     | Walkable `elem` tfeature+       && ConsideredByAI `elem` tfeature ]+  ++ [ "trail tile not walkable" | Walkable `notElem` tfeature+                                   && Trail `elem` tfeature ]+  ++ [ "OftenItem and NoItem on a tile" | OftenItem `elem` tfeature+                                          && NoItem `elem` tfeature ]+  ++ [ "OftenActor and NoActor on a tile" | OftenItem `elem` tfeature+                                            && NoItem `elem` tfeature ]+  ++ (let f :: Feature -> Bool+          f OpenTo{} = True+          f CloseTo{} = True+          f ChangeTo{} = True+          f _ = False+          ts = filter f tfeature+      in [ "more than one OpenTo, CloseTo and ChangeTo specification"+         | length ts > 1 ])+  ++ (let f :: Feature -> Bool+          f HideAs{} = True+          f _ = False+          ts = filter f tfeature+      in ["more than one HideAs specification" | length ts > 1])+  ++ (let f :: Feature -> Bool+          f BuildAs{} = True+          f _ = False+          ts = filter f tfeature+      in ["more than one BuildAs specification" | length ts > 1])+  ++ concatMap (validateDups t)+       [ Walkable, Clear, Dark, OftenItem, VeryOftenItem, OftenActor+       , NoItem, NoActor, ConsideredByAI, Trail, Spice ]++validateDups :: TileKind -> Feature -> [Text]+validateDups TileKind{..} feat =+  let ts = filter (== feat) tfeature+  in ["more than one" <+> tshow feat <+> "specification" | length ts > 1]++-- | Validate all tile kinds.+--+-- We don't check it any more, but if tiles look the same on the map+-- (symbol and color), their substantial features should be the same, too,+-- unless there is a good reason they shouldn't. Otherwise the player has+-- to inspect manually all the tiles with this look to see if any is special.+-- This tends to be tedious. Note that tiles may freely differ wrt text blurb,+-- dungeon generation rules, AI preferences, etc., whithout causing the tedium.+validateAll :: [TileKind] -> ContentData TileKind -> [Text]+validateAll content cotile =+  let f :: Feature -> Bool+      f HideAs{} = True+      f BuildAs{} = True+      f _ = False+      wrongGrooup k grp = not (oisSingletonGroup cotile grp)+                          || isJust (grp `lookup` tfreq k)+      wrongFooAsGroups =+        [ cgroup+        | k <- content+        , let (cgroup, notSingleton) = case find f (tfeature k) of+                Just (HideAs grp) | wrongGrooup k grp -> (grp, True)+                Just (BuildAs grp) | wrongGrooup k grp -> (grp, True)+                _ -> (undefined, False)+        , notSingleton+        ]+  in [ "HideAs or BuildAs groups not singletons or point to themselves:"+       <+> tshow wrongFooAsGroups+     | not $ null wrongFooAsGroups ]+     ++ [ "unknown tile (the first) should be the unknown one"+        | talter (head content) /= 1+          || tname (head content) /= "unknown space" ]+     ++ [ "no tile other than the unknown (the first) should require skill 1"+        | any (\tk -> talter tk == 1) (tail content) ]++-- * Mandatory item groups++mandatoryGroupsSingleton :: [GroupName TileKind]+mandatoryGroupsSingleton =+       [S_UNKNOWN_SPACE, S_UNKNOWN_OUTER_FENCE, S_BASIC_OUTER_FENCE]++pattern S_UNKNOWN_SPACE, S_UNKNOWN_OUTER_FENCE, S_BASIC_OUTER_FENCE :: GroupName TileKind++mandatoryGroups :: [GroupName TileKind]+mandatoryGroups = []++pattern S_UNKNOWN_SPACE = GroupName "unknown space"+pattern S_UNKNOWN_OUTER_FENCE = GroupName "unknown outer fence"+pattern S_BASIC_OUTER_FENCE = GroupName "basic outer fence"++-- * Optional item groups++pattern AQUATIC :: GroupName TileKind++pattern AQUATIC = GroupName "aquatic"++isUknownSpace :: ContentId TileKind -> Bool+{-# INLINE isUknownSpace #-}+isUknownSpace tt = toContentId 0 == tt++unknownId :: ContentId TileKind+{-# INLINE unknownId #-}+unknownId = toContentId 0++isSuspectKind :: TileKind -> Bool+isSuspectKind t =+  let getTo RevealAs{} = True+      getTo ObscureAs{} = True+      getTo _ = False+  in any getTo $ tfeature t++isOpenableKind :: TileKind -> Bool+isOpenableKind t =+  let getTo OpenTo{} = True+      getTo _ = False+  in any getTo $ tfeature t++isClosableKind :: TileKind -> Bool+isClosableKind t =+  let getTo CloseTo{} = True+      getTo _ = False+  in any getTo $ tfeature t++talterForStairs :: Word8+talterForStairs = 3++floorSymbol :: Char+floorSymbol = '·'  -- '\x00B7'++-- Alter skill schema:+-- 0  can be altered by everybody (escape)+-- 1  unknown only+-- 2  openable and suspect+-- 3  stairs+-- 4  closable+-- 5  changeable (e.g., caches)+-- 10  weak obstructions+-- 50  considerable obstructions+-- 100  walls+-- maxBound  impenetrable walls, etc., can never be altered++makeData :: [TileKind] -> [GroupName TileKind] -> [GroupName TileKind]+         -> ContentData TileKind+makeData content groupNamesAtMostOne groupNames =+  makeContentData "TileKind" tname tfreq validateSingle validateAll content+                  (mandatoryGroupsSingleton ++ groupNamesAtMostOne)+                  (mandatoryGroups ++ groupNames)
+ definition-src/Game/LambdaHack/Core/Dice.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Representation of dice scaled with current level depth.+module Game.LambdaHack.Core.Dice+  ( -- * Frequency distribution for casting dice scaled with level depth+    Dice, AbsDepth(..), castDice, d, dL, z, zL, intToDice, minDice, maxDice+  , infsupDice, supDice, infDice, meanDice, reduceDice+    -- * Dice for rolling a pair of integer parameters representing coordinates.+  , DiceXY(..), supDiceXY, infDiceXY+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Data.Binary++-- | Multiple dice rolls, some scaled with current level depth, in which case+-- the sum of all rolls is scaled in proportion to current depth+-- divided by maximal dungeon depth.+--+-- The simple dice should have positive number of rolls and number of sides.+--+-- The @Num@ instance doesn't have @abs@ nor @signum@ defined,+-- because the functions for computing infimum, supremum and mean dice+-- results would be too costly.+data Dice =+    DiceI Int+  | DiceD Int Int+  | DiceDL Int Int+  | DiceZ Int Int+  | DiceZL Int Int+  | DicePlus Dice Dice+  | DiceTimes Dice Dice+  | DiceNegate Dice+  | DiceMin Dice Dice+  | DiceMax Dice Dice+  deriving Eq++instance Show Dice where+  show = stripOuterParens . showDiceWithParens++stripOuterParens :: String -> String+stripOuterParens s@('(' : rest) = case uncons $ reverse rest of+  Just (')', middle) -> reverse middle+  _ -> s+stripOuterParens s = s++showDiceWithParens :: Dice -> String+showDiceWithParens = sh+ where+  sh dice1 = case dice1 of+    DiceI k -> show k+    DiceD n k -> show n ++ "d" ++ show k+    DiceDL n k -> show n ++ "dL" ++ show k+    DiceZ n k -> show n ++ "z" ++ show k+    DiceZL n k -> show n ++ "zL" ++ show k+    DicePlus d1 (DiceNegate d2) -> wrapInParens $ sh d1 ++ "-" ++ sh d2+    DicePlus (DiceNegate d1) d2 -> wrapInParens $ "-" ++ sh d1 ++ "+" ++ sh d2+    DicePlus d1 (DicePlus d2 d3) -> sh $ DicePlus (DicePlus d1 d2) d3+    DicePlus (DicePlus d1 d2) d3 ->+      wrapInParens $ stripOuterParens (sh $ DicePlus d1 d2) ++ "+" ++ sh d3+    DicePlus d1 d2 -> wrapInParens $ sh d1 ++ "+" ++ sh d2+    DiceTimes d1 d2 -> wrapInParens $ sh d1 ++ "*" ++ sh d2+    DiceNegate d1 -> wrapInParens $ "-" ++ sh d1+    DiceMin d1 d2 -> wrapInParens $ "min" ++ sh d1 ++ sh d2+    DiceMax d1 d2 -> wrapInParens $ "max" ++ sh d1 ++ sh d2++wrapInParens :: String -> String+wrapInParens "" = ""+wrapInParens t = "(" <> t <> ")"++instance Num Dice where+  d1 + d2 = DicePlus d1 d2+  d1 * d2 = DiceTimes d1 d2+  d1 - d2 = d1 + DiceNegate d2+  negate = DiceNegate+  abs = undefined  -- very costly to compute mean exactly+  signum = undefined  -- very costly to compute mean exactly+  fromInteger n = DiceI (fromInteger n)++-- | Absolute depth in the dungeon. When used for the maximum depth+-- of the whole dungeon, this can be different than dungeon size,+-- e.g., when the dungeon is branched, and it can even be different+-- than the length of the longest branch, if levels at some depths are missing.+newtype AbsDepth = AbsDepth Int+  deriving (Show, Eq, Ord, Binary)++-- | Cast dice scaled with current level depth. When scaling, we round up,+-- so that the value of @1 `dL` 1@ is @1@ even at the lowest level,+-- but so is the value of @1 `dL` depth@.+--+-- The implementation calls RNG as many times as there are dice rolls,+-- which is costly, so content should prefer to cast fewer dice+-- and then multiply them by a constant. If rounded results are not desired+-- (often they are, to limit the number of distinct item varieties+-- in inventory), another dice may be added to the result.+--+-- A different possible implementation, with dice represented as @Frequency@,+-- makes only one RNG call per dice, but due to lists lengths proportional+-- to the maximal value of the dice, it's is intractable for 1000d1000+-- and problematic already for 100d100.+castDice :: forall m. Monad m+         => ((Int, Int) -> m Int)+         -> AbsDepth -> AbsDepth -> Dice -> m Int+{-# INLINE castDice #-}+castDice randomR (AbsDepth lvlDepth) (AbsDepth maxDepth) dice = do+  let !_A = assert (lvlDepth >= 0 && lvlDepth <= maxDepth+                    `blame` "invalid depth for dice rolls"+                    `swith` (lvlDepth, maxDepth)) ()+      castNK n start k = if start == k then return $! n * k else do+          let f !acc 0 = return acc+              f acc count = do+                r <- randomR (start, k)+                f (acc + r) (count - 1)+          f 0 n+      scaleL k = (k * max 1 lvlDepth) `divUp` max 1 maxDepth+      castD :: Dice -> m Int+      castD dice1 = case dice1 of+        DiceI k -> return k+        DiceD n k -> castNK n 1 k+        DiceDL n k -> scaleL <$> castNK n 1 k+        DiceZ n k -> castNK n 0 (k - 1)+        DiceZL n k -> scaleL <$> castNK n 0 (k - 1)+        DicePlus d1 d2 -> do+          k1 <- castD d1+          k2 <- castD d2+          return $! k1 + k2+        DiceTimes d1 d2 -> do+          k1 <- castD d1+          k2 <- castD d2+          return $! k1 * k2+        DiceNegate d1 -> do+          k <- castD d1+          return $! negate k+        DiceMin d1 d2 -> do+          k1 <- castD d1+          k2 <- castD d2+          return $! min k1 k2+        DiceMax d1 d2 -> do+          k1 <- castD d1+          k2 <- castD d2+          return $! max k1 k2+  castD dice++-- | A die, rolled the given number of times. E.g., @1 `d` 2@ rolls 2-sided+-- die one time.+d :: Int -> Int -> Dice+d n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))+        $ DiceD n k++-- | A die rolled the given number of times,+-- with the result scaled with dungeon level depth.+dL :: Int -> Int -> Dice+dL n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))+         $ DiceDL n k++-- | A die, starting from zero, ending at one less than second argument,+-- rolled the given number of times. E.g., @1 `z` 1@ always rolls zero.+z :: Int -> Int -> Dice+z n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))+        $ DiceZ n k++-- | A die, starting from zero, ending at one less than second argument,+-- rolled the given number of times,+-- with the result scaled with dungeon level depth.+zL :: Int -> Int -> Dice+zL n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k))+         $ DiceZL n k++intToDice :: Int -> Dice+intToDice = DiceI++minDice :: Dice -> Dice -> Dice+minDice = DiceMin++maxDice :: Dice -> Dice -> Dice+maxDice = DiceMax++-- | Minimal and maximal possible value of the dice.+--+-- @divUp@ in the implementation corresponds to @ceiling@,+-- applied to results of @meanDice@ elsewhere in the code,+-- and prevents treating 1d1-power effects (on shallow levels) as null effects.+infsupDice :: Dice -> (Int, Int)+infsupDice dice1 = case dice1 of+  DiceI k -> (k, k)+  DiceD n k -> (n, n * k)+  DiceDL n k -> (1, n * k)  -- bottom and top level considered+  DiceZ n k -> (0, n * (k - 1))+  DiceZL n k -> (0, n * (k - 1))  -- bottom and top level considered+  DicePlus d1 d2 ->+    let (infD1, supD1) = infsupDice d1+        (infD2, supD2) = infsupDice d2+    in (infD1 + infD2, supD1 + supD2)+  DiceTimes (DiceI k) d2 ->+    let (infD2, supD2) = infsupDice d2+    in if k >= 0 then (k * infD2, k * supD2) else (k * supD2, k * infD2)+  DiceTimes d1 (DiceI k) ->+    let (infD1, supD1) = infsupDice d1+    in if k >= 0 then (infD1 * k, supD1 * k) else (supD1 * k, infD1 * k)+  -- Multiplication other than the two cases above is unlikely, but here it is.+  DiceTimes d1 d2 ->+    let (infD1, supD1) = infsupDice d1+        (infD2, supD2) = infsupDice d2+        options = [infD1 * infD2, infD1 * supD2, supD1 * supD2, supD1 * infD2]+    in (minimum options, maximum options)+  DiceNegate d1 ->+    let (infD1, supD1) = infsupDice d1+    in (negate supD1, negate infD1)+  DiceMin d1 d2 ->+    let (infD1, supD1) = infsupDice d1+        (infD2, supD2) = infsupDice d2+    in (min infD1 infD2, min supD1 supD2)+  DiceMax d1 d2 ->+    let (infD1, supD1) = infsupDice d1+        (infD2, supD2) = infsupDice d2+    in (max infD1 infD2, max supD1 supD2)++-- | Maximal value of dice. The scaled part taken assuming median level.+supDice :: Dice -> Int+supDice = snd . infsupDice++-- | Minimal value of dice. The scaled part taken assuming median level.+infDice :: Dice -> Int+infDice = fst . infsupDice++-- | Mean value of dice. The scaled part taken assuming median level,+-- but not taking into account rounding up, and so too low, especially+-- for dice small compared to depth. To fix this, depth would need+-- to be taken as argument.+meanDice :: Dice -> Double+meanDice dice1 = case dice1 of+  DiceI k -> intToDouble k+  DiceD n k -> intToDouble (n * (k + 1)) / 2+  DiceDL n k -> intToDouble (n * (k + 1)) / 4+  DiceZ n k -> intToDouble (n * k) / 2+  DiceZL n k -> intToDouble (n * k) / 4+  DicePlus d1 d2 -> meanDice d1 + meanDice d2+  DiceTimes d1 d2 -> meanDice d1 * meanDice d2  -- I hope this is that simple+  DiceNegate d1 -> negate $ meanDice d1+  DiceMin d1 d2 -> min (meanDice d1) (meanDice d2)+    -- crude approximation, only exact if the distributions disjoint+  DiceMax d1 d2 -> max (meanDice d1) (meanDice d2)  -- crude approximation++reduceDice :: Dice -> Maybe Int+reduceDice d1 =+  let (infD1, supD1) = infsupDice d1+  in if infD1 == supD1 then Just infD1 else Nothing++-- | Dice for rolling a pair of integer parameters pertaining to,+-- respectively, the X and Y cartesian 2D coordinates.+data DiceXY = DiceXY Dice Dice+  deriving Show++-- | Maximal value of DiceXY.+supDiceXY :: DiceXY -> (Int, Int)+supDiceXY (DiceXY x y) = (supDice x, supDice y)++-- | Minimal value of DiceXY.+infDiceXY :: DiceXY -> (Int, Int)+infDiceXY (DiceXY x y) = (infDice x, infDice y)
+ definition-src/Game/LambdaHack/Core/Frequency.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveGeneric, DeriveTraversable, TupleSections #-}+-- | A list of entities with relative frequencies of appearance.+module Game.LambdaHack.Core.Frequency+  ( -- * The @Frequency@ type+    Frequency+    -- * Construction+  , uniformFreq, toFreq, maxBoundInt32+    -- * Transformation+  , scaleFreq+    -- * Consumption+  , nullFreq, runFrequency, nameFrequency+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Control.Applicative+import Data.Int (Int32)+import GHC.Generics (Generic)++maxBoundInt32 :: Int+maxBoundInt32 = toIntegralCrash (maxBound :: Int32)++-- | The frequency distribution type. Not normalized (operations may+-- or may not group the same elements and sum their frequencies). However,+-- elements with less than zero frequency are removed upon construction.+--+-- The @Eq@ instance compares raw representations, not relative,+-- normalized frequencies, so operations don't need to preserve+-- the expected equalities.+data Frequency a = Frequency+  { runFrequency  :: [(Int, a)]  -- ^ give acces to raw frequency values+  , nameFrequency :: Text        -- ^ short description for debug, etc.+  }+  deriving (Show, Eq, Ord, Foldable, Traversable, Generic)++instance Monad Frequency where+  Frequency xs name >>= f =+    Frequency [+#ifdef WITH_EXPENSIVE_ASSERTIONS+                assert (toInteger p * toInteger q <= toInteger maxBoundInt32+                        `blame` (name, map fst xs))+#endif+                (p * q, y)+              | (p, x) <- xs+              , (q, y) <- runFrequency (f x)+              ]+              ("bind (" <> name <> ")")++instance Functor Frequency where+  fmap f (Frequency xs name) = Frequency (map (second f) xs) name++instance Applicative Frequency where+  {-# INLINE pure #-}+  pure x = Frequency [(1, x)] "pure"+  Frequency fs fname <*> Frequency ys yname =+    Frequency [+#ifdef WITH_EXPENSIVE_ASSERTIONS+                assert (toInteger p * toInteger q <= toInteger maxBoundInt32+                        `blame` (fname, map fst fs, yname, map fst ys))+#endif+                (p * q, f y)+              | (p, f) <- fs+              , (q, y) <- ys+              ]+              ("(" <> fname <> ") <*> (" <> yname <> ")")++instance MonadPlus Frequency where+  mplus (Frequency xs xname) (Frequency ys yname) =+    let name = case (xs, ys) of+          ([], []) -> "[]"+          ([], _) -> yname+          (_, []) -> xname+          _ -> "(" <> xname <> ") ++ (" <> yname <> ")"+    in Frequency (xs ++ ys) name+  mzero = Frequency [] "[]"++instance Alternative Frequency where+  (<|>) = mplus+  empty = mzero++-- | Uniform discrete frequency distribution.+uniformFreq :: Text -> [a] -> Frequency a+uniformFreq name l = Frequency (map (1,) l) name++-- | Takes a name and a list of frequencies and items+-- into the frequency distribution.+toFreq :: Text -> [(Int, a)] -> Frequency a+toFreq name l =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  assert (all (\(p, _) -> toInteger p <= toInteger maxBoundInt32) l+          `blame` (name, map fst l)) $+#endif+  Frequency (filter ((> 0 ) . fst) l) name++-- | Scale frequency distribution, multiplying it+-- by a positive integer constant.+scaleFreq :: Show a => Int -> Frequency a -> Frequency a+scaleFreq n (Frequency xs name) =+  assert (n > 0 `blame` "non-positive frequency scale" `swith` (name, n, xs)) $+  let multN p =+#ifdef WITH_EXPENSIVE_ASSERTIONS+                assert (toInteger p * toInteger n <= toInteger maxBoundInt32+                        `blame` (n, Frequency xs name)) $+#endif+                p * n+  in Frequency (map (first multN) xs) name++-- | Test if the frequency distribution is empty.+nullFreq :: Frequency a -> Bool+nullFreq (Frequency fs _) = null fs
+ definition-src/Game/LambdaHack/Core/Prelude.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Custom Prelude, compatible across many GHC versions.+module Game.LambdaHack.Core.Prelude+  ( module Prelude.Compat++  , module Control.Monad.Compat+  , module Data.List.Compat+  , module Data.Maybe+  , module Data.Semigroup.Compat++  , module Control.Exception.Assert.Sugar++  , Text, (<+>), tshow, divUp, sum, (<$$>), partitionM, length, null, comparing+  , into, fromIntegralWrap, toIntegralCrash, intToDouble, int64ToDouble+  , mapM_, forM_, vectorUnboxedUnsafeIndex, unsafeShiftL, unsafeShiftR++  , (***), (&&&), first, second+  ) where++import Prelude ()++import Prelude.Compat hiding+  ( appendFile+  , foldl+  , foldl1+  , fromIntegral+  , length+  , mapM_+  , null+  , readFile+  , sum+  , (<>)+  )++import           Control.Applicative+import           Control.Arrow (first, second, (&&&), (***))+import           Control.DeepSeq+import           Control.Exception.Assert.Sugar+  (allB, assert, blame, showFailure, swith)+import           Control.Monad.Compat hiding (forM_, mapM_)+import qualified Control.Monad.Compat+import           Data.Binary+import qualified Data.Bits as Bits+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Fixed as Fixed+import qualified Data.HashMap.Strict as HM+import           Data.Hashable+import           Data.Int (Int64)+import           Data.Key+import           Data.List.Compat hiding (foldl, foldl1, length, null, sum)+import qualified Data.List.Compat as List+import           Data.Maybe+import           Data.Ord (comparing)+import           Data.Semigroup.Compat (Semigroup ((<>)))+import           Data.Text (Text)+import qualified Data.Text as T (pack)+import qualified Data.Time as Time+import qualified Data.Vector.Unboxed as U+import           NLP.Miniutter.English ((<+>))+import qualified NLP.Miniutter.English as MU+import qualified Prelude.Compat+import           Witch (into)++-- | Show and pack the result.+tshow :: Show a => a -> Text+tshow x = T.pack $ show x++infixl 7 `divUp`+-- | Integer division, rounding up.+divUp :: Integral a => a -> a -> a+{-# INLINE divUp #-}+divUp n k = (n + k - 1) `div` k++sum :: Num a => [a] -> a+sum = foldl' (+) 0++infixl 4 <$$>+(<$$>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+h <$$> m = fmap h <$> m++partitionM :: Applicative m => (a -> m Bool) -> [a] -> m ([a], [a])+{-# INLINE partitionM #-}+partitionM p = foldr (\a ->+  liftA2 (\b -> (if b then first else second) (a :)) (p a)) (pure ([], []))++-- | A version specialized to lists to avoid errors such as taking length+-- of @Maybe [a]@ instead of @[a]@.+-- Such errors are hard to detect, because the type of elements of the list+-- is not constrained.+length :: [a] -> Int+length = List.length++-- | A version specialized to lists to avoid errors such as taking null+-- of @Maybe [a]@ instead of @[a]@.+-- Such errors are hard to detect, because the type of elements of the list+-- is not constrained.+null :: [a] -> Bool+null = List.null++-- Data.Binary orphan instances++instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where+  put m = put (EM.size m) >> mapM_ put (EM.toAscList m)+  get = EM.fromDistinctAscList <$> get++instance (Enum k, Binary k) => Binary (ES.EnumSet k) where+  put m = put (ES.size m) >> mapM_ put (ES.toAscList m)+  get = ES.fromDistinctAscList <$> get++instance Binary Time.NominalDiffTime where+  get = fmap realToFrac (get :: Get Fixed.Pico)+  put = (put :: Fixed.Pico -> Put) . realToFrac++instance (Hashable k, Eq k, Binary k, Binary v) => Binary (HM.HashMap k v) where+  get = fmap HM.fromList get+  put = put . HM.toList++-- Data.Key orphan instances++type instance Key (EM.EnumMap k) = k++instance Zip (EM.EnumMap k) where+  {-# INLINE zipWith #-}+  zipWith = EM.intersectionWith++instance Enum k => ZipWithKey (EM.EnumMap k) where+  {-# INLINE zipWithKey #-}+  zipWithKey = EM.intersectionWithKey++instance Enum k => Keyed (EM.EnumMap k) where+  {-# INLINE mapWithKey #-}+  mapWithKey = EM.mapWithKey++instance Enum k => FoldableWithKey (EM.EnumMap k) where+  {-# INLINE foldrWithKey #-}+  foldrWithKey = EM.foldrWithKey++instance Enum k => TraversableWithKey (EM.EnumMap k) where+  traverseWithKey f = fmap EM.fromDistinctAscList+                      . traverse (\(k, v) -> (,) k <$> f k v) . EM.toAscList++instance Enum k => Indexable (EM.EnumMap k) where+  {-# INLINE index #-}+  index = (EM.!)++instance Enum k => Lookup (EM.EnumMap k) where+  {-# INLINE lookup #-}+  lookup = EM.lookup++instance Enum k => Adjustable (EM.EnumMap k) where+  {-# INLINE adjust #-}+  adjust = EM.adjust++-- Data.Hashable orphan instances++instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where+  hashWithSalt s x = hashWithSalt s (EM.toAscList x)++instance (Enum k, Hashable k) => Hashable (ES.EnumSet k) where+  hashWithSalt s x = hashWithSalt s (ES.toAscList x)++-- Control.DeepSeq orphan instances++instance NFData MU.Part++instance NFData MU.Person++instance NFData MU.Polarity++-- | Re-exported 'Prelude.fromIntegral', but please give it explicit type+-- to make it obvious if wrapping, etc., may occur. Use `toIntegralCrash`+-- instead, if possible, because it fails instead of wrapping, etc.+-- In general, it may wrap or otherwise lose information.+fromIntegralWrap :: (Integral a, Num b) => a -> b+fromIntegralWrap = Prelude.Compat.fromIntegral++-- | Re-exported 'Data.Bits.toIntegralSized', but please give it explicit type+-- to make it obvious if wrapping, etc., may occur and to trigger optimization.+-- In general, it may crash.+toIntegralCrash :: (Integral a, Integral b, Bits.Bits a, Bits.Bits b)+                => a -> b+{-# INLINE toIntegralCrash #-}+toIntegralCrash = fromMaybe (error "toIntegralCrash") . Bits.toIntegralSized++intToDouble :: Int -> Double+intToDouble = Prelude.Compat.fromIntegral++int64ToDouble :: Int64 -> Double+int64ToDouble = Prelude.Compat.fromIntegral++-- | This has a more specific type (unit result) than normally, to catch errors.+mapM_ :: (Foldable t, Monad m) => (a -> m ()) -> t a -> m ()+mapM_ = Control.Monad.Compat.mapM_++-- | This has a more specific type (unit result) than normally, to catch errors.+forM_ :: (Foldable t, Monad m) => t a -> (a -> m ()) -> m ()+forM_ = Control.Monad.Compat.forM_++vectorUnboxedUnsafeIndex :: U.Unbox a => U.Vector a -> Int -> a+vectorUnboxedUnsafeIndex =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  (U.!)  -- index checking is sometimes an expensive (kind of) assertion+#else+  U.unsafeIndex+#endif++unsafeShiftL :: Bits.Bits a => a -> Int -> a+unsafeShiftL =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  Bits.shiftL+#else+  Bits.unsafeShiftL+#endif++unsafeShiftR :: Bits.Bits a => a -> Int -> a+unsafeShiftR =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  Bits.shiftR+#else+  Bits.unsafeShiftR+#endif
+ definition-src/Game/LambdaHack/Core/Random.hs view
@@ -0,0 +1,172 @@+-- | Representation of probabilities and random computations.+module Game.LambdaHack.Core.Random+  ( -- * The @Rng@ monad+    Rnd+    -- * Random operations+  , randomR, randomR0, nextRandom, randomWord32+  , oneOf, shuffle, invalidInformationCode, shuffleExcept, frequency+    -- * Fractional chance+  , Chance, chance+    -- * Casting dice scaled with level+  , castDice, oddsDice, castDiceXY+    -- * Specialized monadic folds+  , foldrM, foldlM'+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , rollFreq+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Monad.Trans.State.Strict as St+import           Data.Int (Int32)+import           Data.Ratio+import qualified Data.Vector.Unboxed as U+import           Data.Word (Word16, Word32)+import qualified System.Random.SplitMix32 as SM++import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Frequency++-- | The monad of computations with random generator state.+type Rnd a = St.State SM.SMGen a++-- | Get a random object within a (inclusive) range with a uniform distribution.+randomR :: (Integral a) => (a, a) -> Rnd a+{-# INLINE randomR #-}+randomR (0, h) = randomR0 h+randomR (l, h) | l > h = error "randomR: empty range"+randomR (l, h) = St.state $ \g ->+  let (x, g') = nextRandom (h - l) g+  in (x + l, g')++-- | Generate random 'Integral' in @[0, x]@ range.+randomR0 :: (Integral a) => a -> Rnd a+{-# INLINE randomR0 #-}+randomR0 h = St.state $ nextRandom h++-- | Generate a random integral value in @[0, x]@ range, where @x@ is within+-- @Int32@.+--+-- The limitation to @Int32@ values is needed to keep it working on signed+-- types. In package @random@, a much more complex scheme is used+-- to keep it working for arbitrary fixed number of bits.+nextRandom :: forall a. (Integral a) => a -> SM.SMGen -> (a, SM.SMGen)+{-# INLINE nextRandom #-}+nextRandom 0 g = (0, g)+nextRandom h g = assert (h > 0 && toInteger h+                                  <= (toInteger :: Int32 -> Integer) maxBound) $+  let (w32, g') = SM.bitmaskWithRejection32'+                    ((fromIntegralWrap :: a -> Word32) h) g+      -- `fromIntegralWrap` is fine here, because wrapping is OK.+      x = (fromIntegralWrap :: Word32 -> a) w32+  in if x > h+     then error $ "nextRandom internal error"+                  `showFailure` (toInteger x, toInteger h, w32)+     else (x, g')++-- | Get a random 'Word32' using full range.+randomWord32 :: Rnd Word32+{-# INLINE randomWord32 #-}+randomWord32 = St.state SM.nextWord32++-- | Get any element of a list with equal probability.+oneOf :: [a] -> Rnd a+oneOf [] = error $ "oneOf []" `showFailure` ()+oneOf [x] = return x+oneOf xs = do+  r <- randomR0 (length xs - 1)+  return $! xs !! r++-- | Generates a random permutation. Naive, but good enough for small inputs.+shuffle :: Eq a => [a] -> Rnd [a]+shuffle [] = return []+shuffle l = do+  x <- oneOf l+  (x :) <$> shuffle (delete x l)++-- | Code that means the information (e.g., flavour or hidden kind index)+-- should be regenerated, because it could not be transferred from+-- previous playthrough (it's random in each playthrough or there was+-- no previous playthrough).+invalidInformationCode :: Word16+invalidInformationCode = maxBound++-- | Generates a random permutation, except for the existing mapping.+shuffleExcept :: U.Vector Word16 -> Int -> [Word16] -> Rnd [Word16]+shuffleExcept v len l0 = assert (len == length l0) $+  shuffleE 0 (l0 \\ filter (/= invalidInformationCode) (U.toList v))+ where+  shuffleE :: Int -> [Word16] -> Rnd [Word16]+  shuffleE i _ | i == len = return []+  shuffleE i l = do+    let a0 = v U.! i+    if a0 == invalidInformationCode then do+      a <- oneOf l+      (a :) <$> shuffleE (succ i) (delete a l)+    else+      (a0 :) <$> shuffleE (succ i) l++-- | Gen an element according to a frequency distribution.+frequency :: Show a => Frequency a -> Rnd a+{-# INLINE frequency #-}+frequency = St.state . rollFreq++-- | Randomly choose an item according to the distribution.+rollFreq :: Show a => Frequency a -> SM.SMGen -> (a, SM.SMGen)+rollFreq fr g = case runFrequency fr of+  [] -> error $ "choice from an empty frequency"+                `showFailure` nameFrequency fr+  [(n, x)] | n <= 0 -> error $ "singleton void frequency"+                               `showFailure` (nameFrequency fr, n, x)+  [(_, x)] -> (x, g)  -- speedup+  fs -> let sumf = foldl' (\ !acc (!n, _) -> acc + n) 0 fs+            (r, ng) = nextRandom (pred sumf) g+            frec :: Int -> [(Int, a)] -> a+            frec !m [] = error $ "impossible roll"+                                 `showFailure` (nameFrequency fr, fs, m)+            frec m ((n, x) : _) | m < n = x+            frec m ((n, _) : xs) = frec (m - n) xs+        in assert (sumf > 0 `blame` "frequency with nothing to pick"+                            `swith` (nameFrequency fr, fs))+             (frec r fs, ng)++-- | Fractional chance.+type Chance = Rational++-- | Give @True@, with probability determined by the fraction.+chance :: Chance -> Rnd Bool+chance r = do+  let n = numerator r+      d = denominator r+  k <- randomR (1, d)+  return (k <= n)++-- | Cast dice scaled with current level depth.+castDice :: Dice.AbsDepth -> Dice.AbsDepth -> Dice.Dice -> Rnd Int+castDice = Dice.castDice randomR++-- | Cast dice scaled with current level depth and return @True@+-- if the results is greater than 50.+oddsDice :: Dice.AbsDepth -> Dice.AbsDepth -> Dice.Dice -> Rnd Bool+oddsDice ldepth totalDepth dice = do+  c <- castDice ldepth totalDepth dice+  return $! c > 50++-- | Cast dice, scaled with current level depth, for coordinates.+castDiceXY :: Dice.AbsDepth -> Dice.AbsDepth -> Dice.DiceXY -> Rnd (Int, Int)+castDiceXY ldepth totalDepth (Dice.DiceXY dx dy) = do+  x <- castDice ldepth totalDepth dx+  y <- castDice ldepth totalDepth dy+  return (x, y)++foldrM :: Foldable t => (a -> b -> Rnd b) -> b -> t a -> Rnd b+foldrM f z0 xs = let f' x (z, g) = St.runState (f x z) g+                 in St.state $ \g -> foldr f' (z0, g) xs++foldlM' :: Foldable t => (b -> a -> Rnd b) -> b -> t a -> Rnd b+foldlM' f z0 xs = let f' (z, g) x = St.runState (f z x) g+                  in St.state $ \g -> foldl' f' (z0, g) xs
+ definition-src/Game/LambdaHack/Definition/Ability.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Abilities of items, actors and factions.+module Game.LambdaHack.Definition.Ability+  ( Skill(..), Skills, Flag(..), ActivationFlag(..), Flags(..)+  , Doctrine(..), EqpSlot(..)+  , getSk, addSk, checkFl, skillsToList+  , zeroSkills, addSkills, sumScaledSkills+  , nameDoctrine, describeDoctrine, doctrineSkills+  , blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , scaleSkills+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Hashable (Hashable)+import           GHC.Generics (Generic)++-- | Actor and faction skills. They are a subset of actor aspects.+-- See 'Game.LambdaHack.Client.UI.EffectDescription.skillDesc'+-- for documentation.+data Skill =+  -- Stats, that is skills affecting permitted actions.+    SkMove+  | SkMelee+  | SkDisplace+  | SkAlter+  | SkWait+  | SkMoveItem+  | SkProject+  | SkApply+  -- Assorted skills.+  | SkSwimming+  | SkFlying+  | SkHurtMelee+  | SkArmorMelee+  | SkArmorRanged+  | SkMaxHP+  | SkMaxCalm+  | SkSpeed+  | SkSight  -- ^ FOV radius, where 1 means a single tile FOV area+  | SkSmell+  | SkShine+  | SkNocto+  | SkHearing+  | SkAggression+  | SkOdor+  | SkDeflectRanged  -- ^ intended to reflect how many items granting complete+                     --   invulnerability are among organs and equipment;+                     --   this is not strength of deflection nor duration, etc.+  | SkDeflectMelee   -- ^ see above+  deriving (Show, Eq, Enum, Bounded, Generic)++-- | Strength of particular skills. This is cumulative from actor+-- organs and equipment and so pertain to an actor as well as to items.+--+-- This representation is sparse, so better than a record when there are more+-- item kinds (with few skills) than actors (with many skills),+-- especially if the number of skills grows as the engine is developed.+-- It's also easier to code and maintain.+--+-- The tree is by construction sparse, so the derived equality is semantical.+newtype Skills = Skills {skills :: EM.EnumMap Skill Int}+  deriving (Show, Eq, Ord, Hashable, Binary)++-- | Item flag aspects.+data Flag =+    Fragile       -- ^ as a projectile, break at target tile, even if no hit;+                  --   also, at each periodic activation a copy is destroyed+                  --   and all other copies require full cooldown (timeout)+  | Lobable       -- ^ drop at target tile, even if no hit+  | Durable       -- ^ don't break even when hitting or applying+  | Equipable     -- ^ AI and UI flag: consider equipping (may or may not+                  --   have 'EqpSlot', e.g., if the benefit is periodic)+  | Benign        -- ^ AI and UI flag: the item is not meant to harm+  | Precious      -- ^ AI and UI flag: don't risk identifying by use;+                  --   also, can't throw or apply if not calm enough;+                  --   also may be used for UI flavour or AI hints+  | Blast         -- ^ the item is an explosion blast particle+  | Condition     -- ^ item is a condition (buff or de-buff) of an actor+                  --   and is displayed as such, not activated at death;+                  --   this differs from belonging to the @CONDITION@ group,+                  --   which doesn't guarantee any behaviour or display,+                  --   but governs removal by items that drop @CONDITION@+  | Unique        -- ^ at most one copy can ever be generated+  | MetaGame      -- ^ once identified, the item is known until savefile deleted+  | MinorEffects  -- ^ override: the effects on this item are considered+                  --   minor and so possibly not causing identification on use,+                  --   and so this item will identify on pick-up+  | MinorAspects  -- ^ override: don't show question marks by weapons in HUD+                  --   even when unidentified item with this flag equipped+  | -- The flags below specify all conditions under which the item activates,+    -- charges permitting, in addition to universal conditions, which are+    -- hitting an actor as projectiles and being explicitly triggered+    -- by an actor (item destruction and combining only pertain+    -- to explicitly listed effects).+    Meleeable     -- ^ meleeing with the item is permitted and so the item+                  --   activates when meleed with+  | Periodic      -- ^ at most one of any copies without cooldown (timeout)+                  --   activates each turn; the cooldown required after+                  --   activation is specified in @Timeout@ (or is zero);+                  --   the initial cooldown can also be specified+                  --   as @TimerDice@ in @CreateItem@ effect; uniquely, this+                  --   activation never destroys a copy, unless item is fragile;+                  --   all this happens only for items in equipment or organs;+                  --   kinetic damage is not applied+  | UnderRanged   -- ^ activates when non-projectile actor with this item+                  --   as equipment or organ is under ranged attack;+                  --   kinetic damage is not applied+  | UnderMelee    -- ^ activates when non-projectile actor with this item+                  --   as equipment or organ is under melee attack;+                  --   kinetic damage is not applied+  deriving (Show, Eq, Enum, Bounded, Generic)++-- | These flags correspond to the last cases of @Flag@ and addtionally+-- to all the universal circumstances of item activation,+-- under which every item activates (even if vacuusly).+data ActivationFlag =+    ActivationMeleeable+  | ActivationPeriodic+  | ActivationUnderRanged+  | ActivationUnderMelee+  | -- | From here on, all items affected regardless of their `Flag` content.+    ActivationProjectile+  | ActivationTrigger+  | ActivationOnSmash+  | ActivationOnCombine+  | ActivationEmbed+  | ActivationConsume+  deriving (Show, Eq)++newtype Flags = Flags {flags :: ES.EnumSet Flag}+  deriving (Show, Eq, Ord, Hashable, Binary)++-- | Doctrine of non-leader actors. Apart of determining AI operation,+-- each doctrine implies a skill modifier, that is added to the non-leader+-- skills defined in @fskillsOther@ field of @FactionKind@.+data Doctrine =+    TExplore  -- ^ if enemy nearby, attack, if no items, etc., explore unknown+  | TFollow   -- ^ always follow leader's target or his position if no target+  | TFollowNoItems   -- ^ follow but don't do any item management nor use+  | TMeleeAndRanged  -- ^ only melee and do ranged combat+  | TMeleeAdjacent   -- ^ only melee (or wait)+  | TBlock    -- ^ always only wait, even if enemy in melee range+  | TRoam     -- ^ if enemy nearby, attack, if no items, etc., roam randomly+  | TPatrol   -- ^ find an open and uncrowded area, patrol it according+              --   to sight radius and fallback temporarily to @TRoam@+              --   when enemy is seen by the faction and is within+              --   the actor's sight radius+  deriving (Show, Eq, Enum, Bounded, Generic)++instance Binary Doctrine++instance Hashable Doctrine++-- | AI and UI hints about the role of the item.+data EqpSlot =+    EqpSlotMove+  | EqpSlotMelee+  | EqpSlotDisplace+  | EqpSlotAlter+  | EqpSlotWait+  | EqpSlotMoveItem+  | EqpSlotProject+  | EqpSlotApply+  | EqpSlotSwimming+  | EqpSlotFlying+  | EqpSlotHurtMelee+  | EqpSlotArmorMelee+  | EqpSlotArmorRanged+  | EqpSlotMaxHP+  | EqpSlotSpeed+  | EqpSlotSight+  | EqpSlotShine+  | EqpSlotMiscBonus+  | EqpSlotWeaponFast+  | EqpSlotWeaponBig+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary Skill where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8++instance Binary Flag where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8++instance Binary EqpSlot where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8++instance Hashable Skill++instance Hashable Flag++instance Hashable EqpSlot++getSk :: Skill -> Skills -> Int+{-# INLINE getSk #-}+getSk sk (Skills skills) = EM.findWithDefault 0 sk skills++addSk :: Skill -> Int -> Skills -> Skills+addSk sk n = addSkills (Skills $ EM.singleton sk n)++checkFl :: Flag -> Flags -> Bool+{-# INLINE checkFl #-}+checkFl flag (Flags flags) = flag `ES.member` flags++skillsToList :: Skills -> [(Skill, Int)]+skillsToList (Skills sk) = EM.assocs sk++zeroSkills :: Skills+zeroSkills = Skills EM.empty++-- This avoids costly compaction (required for Eq) even in case of adding+-- empty skills, etc. This function is used a lot.+addSkills :: Skills -> Skills -> Skills+addSkills (Skills sk1) (Skills sk2) =+  let combine _ s1 s2 = case s1 + s2 of+        0 -> Nothing+        s -> Just s+  in Skills $ EM.mergeWithKey combine id id sk1 sk2++scaleSkills :: (Skills, Int) -> Skills+scaleSkills (_, 0) = zeroSkills+scaleSkills (Skills sk, n) = Skills $ EM.map (n *) sk++sumScaledSkills :: [(Skills, Int)] -> Skills+sumScaledSkills = foldr (addSkills . scaleSkills) zeroSkills++nameDoctrine :: Doctrine -> Text+nameDoctrine TExplore        = "explore"+nameDoctrine TFollow         = "follow freely"+nameDoctrine TFollowNoItems  = "follow only"+nameDoctrine TMeleeAndRanged = "fight only"+nameDoctrine TMeleeAdjacent  = "melee only"+nameDoctrine TBlock          = "block only"+nameDoctrine TRoam           = "roam freely"+nameDoctrine TPatrol         = "patrol area"++describeDoctrine :: Doctrine -> Text+describeDoctrine TExplore = "investigate unknown positions, chase targets"+describeDoctrine TFollow = "follow pointman's target or position, grab items"+describeDoctrine TFollowNoItems =+  "follow pointman's target or position, ignore items"+describeDoctrine TMeleeAndRanged =+  "engage in both melee and ranged combat, don't move"+describeDoctrine TMeleeAdjacent = "engage exclusively in melee, don't move"+describeDoctrine TBlock = "block and wait, don't move"+describeDoctrine TRoam = "move freely, chase targets"+describeDoctrine TPatrol = "find and patrol an area"++doctrineSkills :: Doctrine -> Skills+doctrineSkills TExplore = zeroSkills+doctrineSkills TFollow = zeroSkills+doctrineSkills TFollowNoItems = ignoreItems+doctrineSkills TMeleeAndRanged = meleeAndRanged+doctrineSkills TMeleeAdjacent = meleeAdjacent+doctrineSkills TBlock = blockOnly+doctrineSkills TRoam = zeroSkills+doctrineSkills TPatrol = zeroSkills++minusTen, blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems :: Skills++-- To make sure only a lot of weak items can override move-only-leader, etc.+minusTen = Skills $ EM.fromDistinctAscList+                  $ zip [SkMove .. SkApply] (repeat (-10))++blockOnly = Skills $ EM.delete SkWait $ skills minusTen++meleeAdjacent = Skills $ EM.delete SkMelee $ skills blockOnly++-- Melee and reaction fire.+meleeAndRanged = Skills $ EM.delete SkProject $ skills meleeAdjacent++ignoreItems = Skills $ EM.fromList+                     $ zip [SkMoveItem, SkProject, SkApply] (repeat (-10))
+ definition-src/Game/LambdaHack/Definition/Color.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Colours and text attributes.+module Game.LambdaHack.Definition.Color+  ( -- * Colours+    Color(..)+  , defFG, isBright, darkCol, brightCol, stdCol, legalFgCol+  , cVeryBadEvent, cBadEvent, cRisk, cGraveRisk, cVeryGoodEvent, cGoodEvent+  , cVista, cSleep, cWakeUp, cGreed, cNeutralEvent, cRareNeutralEvent+  , cIdentification, cMeta, cBoring, cGameOver, cTutorialHint+  , colorToRGB+    -- * Complete text attributes+  , Highlight (..), Attr(..)+  , highlightToColor, defAttr+    -- * Characters with attributes+  , AttrChar(..), AttrCharW32(..)+  , attrCharToW32, attrCharFromW32+  , fgFromW32, bgFromW32, charFromW32, attrFromW32+  , spaceAttrW32, nbspAttrW32, trimmedLineAttrW32+  , attrChar2ToW32, attrChar1ToW32+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.DeepSeq+import           Data.Binary+import           Data.Bits ((.&.))+import qualified Data.Char as Char+import           GHC.Generics (Generic)++-- | Colours supported by the major frontends.+data Color =+    Black+  | Red+  | Green+  | Brown+  | Blue+  | Magenta+  | Cyan+  | White+  | AltWhite  -- only use for frontend hacks+  | BrBlack+  | BrRed+  | BrGreen+  | BrYellow+  | BrBlue+  | BrMagenta+  | BrCyan+  | BrWhite+  deriving (Show, Read, Eq, Ord, Enum, Generic)++instance Binary Color where+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8++instance NFData Color++-- | The default colours, to optimize attribute setting.+defFG :: Color+defFG = White++-- | A helper for the terminal frontends that display bright via bold.+isBright :: Color -> Bool+isBright c = c > BrBlack++-- | Colour sets. Sorted.+darkCol, brightCol, stdCol, legalFgCol :: [Color]+darkCol = [Red .. Cyan]+brightCol = [BrRed .. BrCyan]  -- BrBlack is not really that bright+stdCol = darkCol ++ brightCol+legalFgCol = darkCol ++ [White, BrBlack] ++ brightCol ++ [BrWhite]++-- See the discussion of colours and the table of colours at+-- https://github.com/LambdaHack/LambdaHack/wiki/Display#colours+-- Another mention of colours, concerning terrain, is in PLAYING.md manual.+-- The manual and this code should follow the wiki.+cVeryBadEvent, cBadEvent, cRisk, cGraveRisk, cVeryGoodEvent, cGoodEvent, cVista, cSleep, cWakeUp, cGreed, cNeutralEvent, cRareNeutralEvent, cIdentification, cMeta, cBoring, cGameOver, cTutorialHint :: Color+cVeryBadEvent = Red+cBadEvent = BrRed+cRisk = Magenta+cGraveRisk = BrMagenta+cVeryGoodEvent = Green+cGoodEvent = BrGreen+cVista = BrGreen+cSleep = Blue+cWakeUp = BrBlue+cGreed = BrBlue+cNeutralEvent = Cyan+cRareNeutralEvent = BrCyan+cIdentification = Brown+cMeta = BrYellow+cBoring = White+cGameOver = BrWhite+cTutorialHint = BrMagenta++-- | Translationg to heavily modified Linux console color RGB values.+--+-- Warning: SDL frontend sadly duplicates this code.+colorToRGB :: Color -> Text+colorToRGB Black     = "#000000"+colorToRGB Red       = "#D50505"+colorToRGB Green     = "#059D05"+colorToRGB Brown     = "#CA4A05"+colorToRGB Blue      = "#0556F4"+colorToRGB Magenta   = "#AF0EAF"+colorToRGB Cyan      = "#059696"+colorToRGB White     = "#B8BFCB"+colorToRGB AltWhite  = "#C4BEB1"+colorToRGB BrBlack   = "#6F5F5F"+colorToRGB BrRed     = "#FF5555"+colorToRGB BrGreen   = "#65F136"+colorToRGB BrYellow  = "#EBD642"+colorToRGB BrBlue    = "#4D98F4"+colorToRGB BrMagenta = "#FF77FF"+colorToRGB BrCyan    = "#52F4E5"+colorToRGB BrWhite   = "#FFFFFF"++-- -- | For reference, the original Linux console colors.+-- -- Good old retro feel and more useful than xterm (e.g. brown).+-- colorToRGB :: Color -> Text+-- colorToRGB Black     = "#000000"+-- colorToRGB Red       = "#AA0000"+-- colorToRGB Green     = "#00AA00"+-- colorToRGB Brown     = "#AA5500"+-- colorToRGB Blue      = "#0000AA"+-- colorToRGB Magenta   = "#AA00AA"+-- colorToRGB Cyan      = "#00AAAA"+-- colorToRGB White     = "#AAAAAA"+-- colorToRGB AltWhite  = "#AAAAAA"+-- colorToRGB BrBlack   = "#555555"+-- colorToRGB BrRed     = "#FF5555"+-- colorToRGB BrGreen   = "#55FF55"+-- colorToRGB BrYellow  = "#FFFF55"+-- colorToRGB BrBlue    = "#5555FF"+-- colorToRGB BrMagenta = "#FF55FF"+-- colorToRGB BrCyan    = "#55FFFF"+-- colorToRGB BrWhite   = "#FFFFFF"++-- | Additional map cell highlight, e.g., a colorful square around the cell+-- or a colorful background.+--+-- Warning: the highlight underscored by the terminal cursor is+-- the maximal element of this type present on a screen,+-- so don't add new highlights to the end.+data Highlight =+    HighlightNone+  | HighlightBackground+  | HighlightGreen+  | HighlightBlue+  | HighlightBrown+  | HighlightCyan+  | HighlightGrey+  | HighlightWhite+  | HighlightMagenta+  | HighlightRed+  | HighlightYellow+  | HighlightYellowAim+  | HighlightRedAim+  | HighlightNoneCursor+  deriving (Show, Eq, Ord, Enum, Bounded)++highlightToColor :: Highlight -> Color+highlightToColor hi = case hi of+  HighlightNone -> Black  -- should be transparent, but is OK in web frontend+  HighlightBackground -> BrBlack  -- gets a special colour, but as a background+  HighlightGreen -> Green+  HighlightBlue -> Blue+  HighlightBrown -> Brown+  HighlightCyan -> Cyan+  HighlightGrey -> BrBlack+  HighlightWhite -> White  -- bright, but no saturation, so doesn't obscure much+  HighlightMagenta -> BrMagenta  -- very rare, so bright is fine+  HighlightRed -> Red+  HighlightYellow -> BrYellow  -- obscures, but mostly used around bright white+  HighlightYellowAim -> BrYellow+  HighlightRedAim -> Red+  HighlightNoneCursor -> Black  -- used in ANSI for cursor via @maxIndexByA@++-- | Text attributes: foreground color and highlight.+data Attr = Attr+  { fg :: Color      -- ^ foreground colour+  , bg :: Highlight  -- ^ highlight+  }+  deriving (Show, Eq)++-- | The default attribute, to optimize attribute setting.+defAttr :: Attr+defAttr = Attr defFG HighlightNone++-- | Character to display, with its attribute.+data AttrChar = AttrChar+  { acAttr :: Attr+  , acChar :: Char+  }+  deriving (Show, Eq)++-- This implementation is faster than @Int@, because some vector updates+-- can be done without going to and from @Int@.+-- | Optimized representation of 'AttrChar'.+newtype AttrCharW32 = AttrCharW32 {attrCharW32 :: Word32}+  deriving (Show, Eq, Ord, Enum, Binary)++attrCharToW32 :: AttrChar -> AttrCharW32+attrCharToW32 AttrChar{acAttr=Attr{..}, acChar} = AttrCharW32 $ toEnum $+  unsafeShiftL (fromEnum fg) 8 + fromEnum bg + unsafeShiftL (Char.ord acChar) 16++attrCharFromW32 :: AttrCharW32 -> AttrChar+attrCharFromW32 !w = AttrChar (attrFromW32 w) (charFromW32 w)++fgFromW32 :: AttrCharW32 -> Color+{-# INLINE fgFromW32 #-}+fgFromW32 w =+  toEnum $ unsafeShiftR (fromEnum $ attrCharW32 w) 8 .&. (2 ^ (8 :: Int) - 1)++bgFromW32 :: AttrCharW32 -> Highlight+{-# INLINE bgFromW32 #-}+bgFromW32 w =+  toEnum $ fromEnum $ attrCharW32 w .&. (2 ^ (8 :: Int) - 1)++charFromW32 :: AttrCharW32 -> Char+{-# INLINE charFromW32 #-}+charFromW32 w =+  Char.chr $ unsafeShiftR (fromEnum $ attrCharW32 w) 16++attrFromW32 :: AttrCharW32 -> Attr+{-# INLINE attrFromW32 #-}+attrFromW32 w = Attr (fgFromW32 w) (bgFromW32 w)++spaceAttrW32 :: AttrCharW32+spaceAttrW32 = attrCharToW32 $ AttrChar defAttr ' '++nbspAttrW32 :: AttrCharW32+nbspAttrW32 = attrCharToW32 $ AttrChar defAttr '\x00a0'++trimmedLineAttrW32 :: AttrCharW32+trimmedLineAttrW32 = attrChar2ToW32 BrBlack '$'++attrChar2ToW32 :: Color -> Char -> AttrCharW32+{-# INLINE attrChar2ToW32 #-}+attrChar2ToW32 fg =+  let fgNum = unsafeShiftL (fromEnum fg) 8+  in \acChar -> AttrCharW32 $ toEnum $ fgNum + unsafeShiftL (Char.ord acChar) 16+--+-- These hacks save one allocation (?) (before fits-in-32bits check) compared+-- to the above, but they fail in GHC 9.2.0 and possibly don't do anything+-- for JS, which is the only real bottleneck, so disabled:+--+--import GHC.Prim (int2Word#)+--  case unsafeShiftL (fromEnum fg) 8 + unsafeShiftL (Char.ord acChar) 16 of+--    I# i -> AttrCharW32 $ W32# (int2Word# i)++attrChar1ToW32 :: Char -> AttrCharW32+{-# INLINE attrChar1ToW32 #-}+attrChar1ToW32 =+  let fgNum = unsafeShiftL (fromEnum White) 8+  in \acChar -> AttrCharW32 $ toEnum $ fgNum + unsafeShiftL (Char.ord acChar) 16+--+--    case fgNum + unsafeShiftL (Char.ord acChar) 16 of+--      I# i -> AttrCharW32 $ W32# (int2Word# i)
+ definition-src/Game/LambdaHack/Definition/ContentData.hs view
@@ -0,0 +1,214 @@+-- | A game requires the engine provided by the library, perhaps customized,+-- and game content, defined completely afresh for the particular game.+-- The possible kinds of content are fixed in the library and all defined+-- within the library source code directory. On the other hand, game content,+-- is defined in the directory hosting the particular game definition.+--+-- Content of a given kind is just a list of content items.+-- After the list is verified and the data preprocessed, it's held+-- in the @ContentData@ datatype.+module Game.LambdaHack.Definition.ContentData+  ( ContentData+  , validateRarity, validFreqs+  , emptyContentData, makeContentData+  , okind, omemberGroup, oexistsGroup, oisSingletonGroup, ouniqGroup, opick+  , ofoldlWithKey', ofoldlGroup', omapVector, oimapVector, olength+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Function+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Vector as V++import Game.LambdaHack.Core.Frequency+import Game.LambdaHack.Core.Random+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Definition.DefsInternal++-- | Verified and preprocessed content data of a particular kind.+data ContentData c = ContentData+  { contentVector :: V.Vector c+  , groupFreq     :: M.Map (GroupName c) [(Int, (ContentId c, c))]+  }++maxContentId :: ContentId k+maxContentId = toContentId maxBound++validateRarity :: Rarity -> [Text]+validateRarity rarity =+  -- @SortOn@ less efficient here, because function cheap.+  let sortedRarity = sortBy (comparing fst) rarity+  in [ "rarity not sorted" | sortedRarity /= rarity ]+     ++ [ "rarity depth thresholds not unique"+        | map head (groupBy ((==) `on` fst) sortedRarity) /= sortedRarity ]+     ++ [ "rarity depth not positive"+        | case sortedRarity of+            ((lowest, _) : _) -> lowest <= 0+            _ -> False ]++validFreqs :: Freqs a -> Bool+validFreqs freqs =+  -- Greater or equal to 0 permitted, e.g., to cover embedded template UNKNOWN+  -- items not yet identified by the client, but triggerable nevertheless.+  all ((>= 0) . snd) freqs+  && let groups = sort $ map fst freqs+         tailOfGroups = if null groups then groups else tail groups+     in all (uncurry (/=)) $ zip groups tailOfGroups++emptyContentData :: ContentData a+emptyContentData = ContentData V.empty M.empty++makeContentData :: Show c+                => String+                -> (c -> Text)+                     -- ^ name of the content itme, used for validation+                -> (c -> Freqs c)+                     -- ^ frequency in groups, for validation and preprocessing+                -> (c -> [Text])+                     -- ^ validate a content item and list all offences+                -> ([c] -> ContentData c -> [Text])+                     -- ^ validate the whole defined content of this type+                     -- and list all offence+                -> [c]  -- ^ all content of this type+                -> [GroupName c]  -- ^ singleton group names for this content+                -> [GroupName c]  -- ^ remaining group names for this content+                -> ContentData c+{-# INLINE makeContentData #-}+makeContentData contentName getName getFreq validateSingle validateAll+                content groupNamesSingleton groupNames =+  -- The @force@ is needed for @GHC.Compact@.+  let contentVector = V.force $ V.fromList content+      groupFreq =+        let tuples = [ (cgroup, (n, (i, k)))+                     | (i, k) <- zip (map toContentId [0..]) content+                     , (cgroup, n) <- getFreq k+                     , n > 0 ]+            f !m (!cgroup, !nik) = M.insertWith (++) cgroup [nik] m+        in foldl' f M.empty tuples+      contentData = ContentData {..}+      singleOffenders = [ (offences, a)+                        | a <- content+                        , let offences = validateSingle a+                                         ++ ["empty name" | T.null (getName a)]+                        , not (null offences) ]+      allOffences = validateAll content contentData+      freqsOffenders = filter (not . validFreqs . getFreq) content+      allGroupNamesEmpty = filter (T.null . fromGroupName)+                           $ groupNamesSingleton ++ groupNames+      allGroupNamesTooLong = filter ((> 30) . T.length . fromGroupName)+                             $ groupNamesSingleton ++ groupNames+      allGroupNamesSorted = sort $ groupNamesSingleton ++ groupNames+      allGroupNamesUnique = nub allGroupNamesSorted+      allGroupNamesNonUnique = allGroupNamesSorted \\ allGroupNamesUnique+      missingGroups = filter (not . omemberGroup contentData)+                             (groupNamesSingleton ++ groupNames)+      groupsMoreThanOne = filter (not . oisSingletonGroup contentData)+                                 groupNamesSingleton+      groupsDeclaredSet = S.fromAscList allGroupNamesUnique+      groupsNotDeclared = filter (`S.notMember` groupsDeclaredSet)+                          $ M.keys groupFreq+  in assert (null allGroupNamesEmpty+             `blame` contentName ++ ": some group names empty"+             `swith` allGroupNamesEmpty) $+     assert (null allGroupNamesTooLong+             `blame` contentName ++ ": some group names too long"+             `swith` allGroupNamesTooLong) $+     assert (null allGroupNamesNonUnique+             `blame` contentName ++ ": some group names duplicated"+             `swith` allGroupNamesNonUnique) $+     assert (null missingGroups+             `blame` contentName ++ ": some group names pertain to no content"+             `swith` missingGroups) $+     assert (null groupsMoreThanOne+             `blame` contentName ++ ": some group names refer to more than one content, while they shouldn't"+             `swith` groupsMoreThanOne) $+     assert (null groupsNotDeclared+             `blame` contentName ++ ": some group names are not included in group name lists, neither singleton nor duplicable"+             `swith` groupsNotDeclared) $+     assert (null freqsOffenders+             `blame` contentName ++ ": some Freqs values not valid"+             `swith` freqsOffenders) $+     assert (null singleOffenders+             `blame` contentName ++ ": some content items not valid"+             `swith` singleOffenders) $+     assert (null allOffences+             `blame` contentName ++ ": the content set is not valid"+             `swith` allOffences) $+     assert (V.length contentVector <= contentIdIndex maxContentId+             `blame` contentName ++ ": the content has too many elements")+     contentData++-- | Content element at given id.+okind :: ContentData a -> ContentId a -> a+{-# INLINE okind #-}+okind ContentData{contentVector} !i = contentVector V.! contentIdIndex i++omemberGroup :: ContentData a -> GroupName a -> Bool+omemberGroup ContentData{groupFreq} cgroup = cgroup `M.member` groupFreq++oexistsGroup :: ContentData a -> GroupName a -> Bool+oexistsGroup ContentData{groupFreq} cgroup = case M.lookup cgroup groupFreq of+  Nothing -> False+  Just l -> all ((> 0) . fst) l++oisSingletonGroup :: ContentData a -> GroupName a -> Bool+oisSingletonGroup ContentData{groupFreq} cgroup =+  case M.lookup cgroup groupFreq of+    Just [_] -> True+    _ -> False++-- | The id of the unique member of a singleton content group.+ouniqGroup :: Show a => ContentData a -> GroupName a -> ContentId a+ouniqGroup ContentData{groupFreq} !cgroup =+  let freq = let assFail = error $ "no unique group"+                                   `showFailure` (cgroup, groupFreq)+             in M.findWithDefault assFail cgroup groupFreq+  in case freq of+    [(n, (i, _))] | n > 0 -> i+    l -> error $ "not unique" `showFailure` (cgroup, l)++-- | Pick a random id belonging to a group and satisfying a predicate.+opick :: Show a+      => ContentData a+      -> GroupName a -> (a -> Bool) -> Rnd (Maybe (ContentId a))+opick ContentData{groupFreq} !cgroup !p =+  case M.lookup cgroup groupFreq of+    Just freqRaw ->+      let freq = toFreq "opick" $ filter (p . snd . snd) freqRaw+      in if nullFreq freq+         then return Nothing+         else Just . fst <$> frequency freq+    _ -> return Nothing++-- | Fold strictly over all content @a@.+ofoldlWithKey' :: ContentData a -> (b -> ContentId a -> a -> b) -> b -> b+ofoldlWithKey' ContentData{contentVector} f z =+  V.ifoldl' (\ !a !i !c -> f a (toContentId $ toEnum i) c) z contentVector++-- | Fold over the given group only.+ofoldlGroup' :: ContentData a+             -> GroupName a+             -> (b -> Int -> ContentId a -> a -> b) -> b -> b+ofoldlGroup' ContentData{groupFreq} cgroup f z =+  case M.lookup cgroup groupFreq of+    Just freq -> foldl' (\ !acc (!p, (!i, !a)) -> f acc p i a) z freq+    _ -> error $ "no group '" ++ show cgroup+                              ++ "' among content that has groups "+                              ++ show (M.keys groupFreq)+                 `showFailure` ()++omapVector :: ContentData a -> (a -> b) -> V.Vector b+omapVector d f = V.map f $ contentVector d++oimapVector :: ContentData a -> (ContentId a -> a -> b) -> V.Vector b+oimapVector d f = V.imap (\i a -> f (toContentId $ toEnum i) a)+                         (contentVector d)++-- | Size of content @a@.+olength :: ContentData a -> Int+olength ContentData{contentVector} = V.length contentVector
+ definition-src/Game/LambdaHack/Definition/Defs.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Basic types for content definitions.+module Game.LambdaHack.Definition.Defs+  ( GroupName, displayGroupName+  , ContentId, contentIdIndex+  , ContentSymbol, displayContentSymbol+  , X, Y+  , Freqs, renameFreqs+  , Rarity, linearInterpolation+  , CStore(..), ppCStore, ppCStoreIn, verbCStore+  , SLore(..), ItemDialogMode(..), ppSLore, headingSLore+  , ppItemDialogMode, ppItemDialogModeIn, ppItemDialogModeFrom, loreFromMode+  , Direction(..)+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Control.DeepSeq+import Data.Binary+import GHC.Generics (Generic)++import Game.LambdaHack.Definition.DefsInternal++-- | X spacial dimension for points and vectors.+type X = Int++-- | Y xpacial dimension for points and vectors.+type Y = Int++-- | For each group that the kind belongs to, denoted by a @GroupName@+-- in the first component of a pair, the second component of a pair shows+-- how common the kind is within the group.+type Freqs c = [(GroupName c, Int)]++renameFreqs :: (Text -> Text) -> Freqs c -> Freqs c+renameFreqs f = map (first (GroupName . f . fromGroupName))++-- | Rarity on given depths. The first element of the pair is normally+-- in (0, 10] interval and, e.g., if there are 20 levels, 0.5 represents+-- the first level and 10 the last. Exceptionally, it may be larger than 10,+-- meaning appearance in the dungeon is not possible under normal circumstances+-- and the value remains constant above the interval bound.+type Rarity = [(Double, Int)]++-- We assume depths are greater or equal to one and the rarity @dataset@+-- is non-empty, sorted and the first elements of the pairs are positive.+-- The convention for adding implicit outer intervals is that+-- the value increases linearly, starting from 0 at 0. Similarly,+-- if the last interval ends before 10, the value drops linearly,+-- in a way that would reach 0 a step after 10, but staying constant+-- from 10 onward. If the last interval ends after 10, the value stays constant+-- after the interval's upper bound.+--+-- Note that rarity [(1, 1)] means constant value 1 only thanks to @ceiling@.+-- OTOH, [(1, 10)] is not equivalent to [(10/150, 10)] in a 150-deep dungeon,+-- since its value at the first level is drastically lower. This only+-- matters if content creators mix the two notations, so care must be taken+-- in such cases. Otherwise, for any given level, all kinds scale consistently+-- and the simpler notation just paintes the dungeon in larger strokes.+linearInterpolation :: Int -> Int -> Rarity -> Int+linearInterpolation !levelDepthInt !totalDepthInt !dataset =+  let levelDepth10 = intToDouble $ levelDepthInt * 10+      totalDepth = intToDouble totalDepthInt+      findInterval :: (Double, Int) -> Rarity -> ((Double, Int), (Double, Int))+      findInterval x1y1@(x1Last, y1Last) [] =  -- we are past the last interval+        let stepLevel = 10 / totalDepth+              -- this is the distance representing one level, the same+              -- as the distance from 0 to the representation of level 1+            yConstant = if x1Last >= 10+                        then y1Last+                        else ceiling (intToDouble y1Last * stepLevel+                                      / (10 + stepLevel - x1Last))+              -- this is the value of the interpolation formula at the end+              -- with y2 == 0, levelDepth10 == totalDepth * 10,+              -- and x2 == 10 + stepLevel+        in if levelDepthInt > totalDepthInt  -- value stays constant+           then ((x1Last, yConstant), (x1Last + 1, yConstant))+                  -- this artificial interval is enough to emulate+                  -- the value staying constant indefinitely+           else (x1y1, (10 + stepLevel, 0))+      findInterval !x1y1 ((!x, !y) : rest) =+        if levelDepth10 <= x * totalDepth+        then (x1y1, (x, y))+        else findInterval (x, y) rest+      ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset+  in y1 + ceiling+            (intToDouble (y2 - y1) * (levelDepth10 - x1 * totalDepth)+             / ((x2 - x1) * totalDepth))++-- | Actor's item stores.+data CStore =+    CGround+  | COrgan+  | CEqp+  | CStash+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)++instance Binary CStore++instance NFData CStore++ppCStore :: CStore -> (Text, Text)+ppCStore CGround = ("on", "the ground")+ppCStore COrgan = ("in", "body")+ppCStore CEqp = ("in", "equipment outfit")+ppCStore CStash = ("in", "shared inventory stash")++ppCStoreIn :: CStore -> Text+ppCStoreIn c = let (tIn, t) = ppCStore c in tIn <+> t++verbCStore :: CStore -> Text+verbCStore CGround = "remove"+verbCStore COrgan = "implant"+verbCStore CEqp = "equip"+verbCStore CStash = "stash"++-- | Item slot and lore categories.+data SLore =+    SItem+  | SOrgan+  | STrunk+  | SCondition+  | SBlast+  | SEmbed+  | SBody  -- contains the sum of @SOrgan@, @STrunk@ and @SCondition@+           -- but only present in the current pointman's body+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)++instance Binary SLore++instance NFData SLore++data ItemDialogMode =+    MStore CStore  -- ^ a leader's store+  | MOwned         -- ^ all party's items+  | MSkills        -- ^ not items, but determined by leader's items+  | MLore SLore    -- ^ not party's items, but all known generalized items+  | MPlaces        -- ^ places; not items at all, but definitely a lore+  | MFactions      -- ^ factions in this game, with some data from previous+  | MModes         -- ^ scenarios; not items at all, but definitely a lore+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData ItemDialogMode++instance Binary ItemDialogMode++ppSLore :: SLore -> Text+ppSLore SItem = "item"+ppSLore SOrgan = "organ"+ppSLore STrunk = "creature"+ppSLore SCondition = "condition"+ppSLore SBlast = "blast"+ppSLore SEmbed = "terrain"+ppSLore SBody = "body"++headingSLore :: SLore -> Text+headingSLore SItem = "miscellaneous item"+headingSLore SOrgan = "vital anatomic organ"+headingSLore STrunk = "autonomous entity"+headingSLore SCondition = "momentary bodily condition"+headingSLore SBlast = "explosion blast particle"+headingSLore SEmbed = "landmark feature"+headingSLore SBody = "body part"++ppItemDialogMode :: ItemDialogMode -> (Text, Text)+ppItemDialogMode (MStore cstore) = ppCStore cstore+ppItemDialogMode MOwned = ("among", "our total team belongings")+ppItemDialogMode MSkills = ("among", "skills")+ppItemDialogMode (MLore SBody) = ("in", "body")+ppItemDialogMode (MLore slore) = ("among", ppSLore slore <+> "lore")+ppItemDialogMode MPlaces = ("among", "place lore")+ppItemDialogMode MFactions = ("among", "faction lore")+ppItemDialogMode MModes = ("among", "adventure lore")++ppItemDialogModeIn :: ItemDialogMode -> Text+ppItemDialogModeIn c = let (tIn, t) = ppItemDialogMode c in tIn <+> t++ppItemDialogModeFrom :: ItemDialogMode -> Text+ppItemDialogModeFrom c = let (_tIn, t) = ppItemDialogMode c in "from" <+> t++loreFromMode :: ItemDialogMode -> SLore+loreFromMode c = case c of+  MStore COrgan -> SOrgan+  MStore _ -> SItem+  MOwned -> SItem+  MSkills -> undefined  -- artificial slots+  MLore slore -> slore+  MPlaces -> undefined  -- artificial slots+  MFactions -> undefined  -- artificial slots+  MModes -> undefined  -- artificial slots++data Direction = Forward | Backward+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData Direction++instance Binary Direction
+ definition-src/Game/LambdaHack/Definition/DefsInternal.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Very basic types for content definitions with their internals exposed.+module Game.LambdaHack.Definition.DefsInternal+  ( GroupName(..), displayGroupName+  , ContentId, toContentId, fromContentId, contentIdIndex+  , ContentSymbol, toContentSymbol, displayContentSymbol+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Control.DeepSeq+import Data.Binary+import Data.Hashable++-- If ever needed, we can use a symbol table here, since content+-- is never serialized. But we'd need to cover the few cases+-- (e.g., @litemFreq@) where @GroupName@ goes into savegame.+newtype GroupName c = GroupName {fromGroupName :: Text}+  deriving (Show, Eq, Ord, Hashable, Binary, NFData)++-- | This does not need to be 1-1, so should not be used in place of the+-- 'Eq' instance, etc.+displayGroupName :: GroupName c -> Text+displayGroupName = fromGroupName++-- | Content identifiers for the content type @c@.+newtype ContentId c = ContentId Word16+  deriving (Show, Eq, Ord, Enum, Hashable, Binary)++toContentId :: Word16 -> ContentId c+{-# INLINE toContentId #-}+toContentId = ContentId++fromContentId :: ContentId c -> Word16+{-# INLINE fromContentId #-}+fromContentId (ContentId k) = k++contentIdIndex :: ContentId c -> Int+{-# INLINE contentIdIndex #-}+contentIdIndex (ContentId k) = fromEnum k++-- TODO: temporary, not to break compilation too soon:+--{--+type ContentSymbol c = Char+toContentSymbol :: Char -> ContentSymbol c+toContentSymbol = id+displayContentSymbol :: ContentSymbol c -> Char+displayContentSymbol = id+--}++-- TODO: The intended definitions. Error they are going to cause will+-- point out all the remaining item symbols hardwired in the engine+-- and make any future accidental hardwiring harder.+-- TODO2: extend to other content kinds than item kinds.+{-+-- | An abstract view on the symbol of a content item definition.+-- Hiding the constructor prevents hardwiring symbols inside the engine+-- by accident (this is still possible via conversion functions,+-- if one insists, so the abstraction is leaky, but that's fine).+newtype ContentSymbol c = ContentSymbol Char+  deriving (Show, Eq, Ord, Binary, NFData)  -- TODO: Generic and most others are only needed for TriggerItem, so once the latter is removed, these instances can go.++-- | This is a 1-1 inclusion. Don't use, if an equal named symbol already+-- exists in rules content.+toContentSymbol :: Char -> ContentSymbol c+{-# INLINE toContentSymbol #-}+toContentSymbol = ContentSymbol++-- | This does not need to be 1-1, so should not be used in place of the+-- 'Eq' instance, etc.+displayContentSymbol :: ContentSymbol c -> Char+{-# INLINE displayContentSymbol #-}+displayContentSymbol (ContentSymbol c) = c+--}
+ definition-src/Game/LambdaHack/Definition/Flavour.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DeriveGeneric #-}+-- | The appearance of in-game items, as communicated to the player.+module Game.LambdaHack.Definition.Flavour+  ( -- * The @Flavour@ type+    Flavour+  , -- * Constructors+    zipPlain, zipFancy, zipLiquid, zipGlassPlain, zipGlassFancy, zipStory+  , dummyFlavour, stdFlavList+  , -- * Accessors+    flavourToColor, flavourToName+    -- * Assorted+  , colorToPlainName, colorToFancyName, colorToTeamName+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , FancyName, colorToLiquidName, colorToGlassPlainName, colorToGlassFancyName+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Data.Binary+import Data.Bits ((.&.))+import GHC.Generics (Generic)++import Game.LambdaHack.Definition.Color++data FancyName = Plain | Fancy | Liquid | GlassPlain | GlassFancy | Story+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++-- | The type of item flavours.+data Flavour = Flavour+  { fancyName :: FancyName  -- ^ how fancy should the colour description be+  , baseColor :: Color      -- ^ the colour of the flavour+  }+  deriving (Show, Eq, Ord, Generic)++instance Enum Flavour where+  fromEnum Flavour{..} =+    unsafeShiftL (fromEnum fancyName) 8 + fromEnum baseColor+  toEnum n = Flavour (toEnum $ unsafeShiftR n 8)+                     (toEnum $ n .&. (2 ^ (8 :: Int) - 1))++instance Binary Flavour where+  put = put . (toIntegralCrash :: Int -> Word16) . fromEnum+  get = fmap (toEnum . (into :: Word16 -> Int)) get  -- @Int doesn't suffice++dummyFlavour :: Flavour+dummyFlavour = Flavour Story Black++stdFlavList :: [Flavour]+stdFlavList = [Flavour fn bc | fn <- [minBound..maxBound], bc <- stdCol]++-- | Turn a colour set into a flavour set.+zipPlain, zipFancy, zipLiquid, zipGlassPlain, zipGlassFancy, zipStory :: [Color] -> [Flavour]+zipPlain = map (Flavour Plain)+zipFancy = map (Flavour Fancy)+zipLiquid = map (Flavour Liquid)+zipGlassPlain = map (Flavour GlassPlain)+zipGlassFancy = map (Flavour GlassFancy)+zipStory = map (Flavour Story)++-- | Get the underlying base colour of a flavour.+flavourToColor :: Flavour -> Color+flavourToColor Flavour{baseColor} = baseColor++-- | Construct the full name of a flavour.+flavourToName :: Flavour -> Text+flavourToName Flavour{fancyName=Plain, ..} = colorToPlainName baseColor+flavourToName Flavour{fancyName=Fancy, ..} = colorToFancyName baseColor+flavourToName Flavour{fancyName=Liquid, ..} = colorToLiquidName baseColor+flavourToName Flavour{fancyName=GlassPlain, ..} =+  colorToGlassPlainName baseColor+flavourToName Flavour{fancyName=GlassFancy, ..} =+  colorToGlassFancyName baseColor+flavourToName Flavour{fancyName=Story, ..} =+  colorToStoryName baseColor++-- | Human-readable names for item colors. The plain set.+colorToPlainName :: Color -> Text+colorToPlainName Black     = "black"+colorToPlainName Red       = "red"+colorToPlainName Green     = "green"+colorToPlainName Brown     = "brown"+colorToPlainName Blue      = "blue"+colorToPlainName Magenta   = "purple"+colorToPlainName Cyan      = "cyan"+colorToPlainName White     = "ivory"+colorToPlainName AltWhite  = error "colorToPlainName: illegal color"+colorToPlainName BrBlack   = "gray"+colorToPlainName BrRed     = "coral"+colorToPlainName BrGreen   = "lime"+colorToPlainName BrYellow  = "yellow"+colorToPlainName BrBlue    = "azure"+colorToPlainName BrMagenta = "pink"+colorToPlainName BrCyan    = "aquamarine"+colorToPlainName BrWhite   = "white"++-- | Human-readable names for item colors. The fancy set.+colorToFancyName :: Color -> Text+colorToFancyName Black     = "smoky-black"+colorToFancyName Red       = "apple-red"+colorToFancyName Green     = "forest-green"+colorToFancyName Brown     = "mahogany"+colorToFancyName Blue      = "royal-blue"+colorToFancyName Magenta   = "indigo"+colorToFancyName Cyan      = "teal"+colorToFancyName White     = "silver-gray"+colorToFancyName AltWhite  = error "colorToFancyName: illegal color"+colorToFancyName BrBlack   = "charcoal"+colorToFancyName BrRed     = "salmon"+colorToFancyName BrGreen   = "emerald"+colorToFancyName BrYellow  = "amber"+colorToFancyName BrBlue    = "sky-blue"+colorToFancyName BrMagenta = "magenta"+colorToFancyName BrCyan    = "turquoise"+colorToFancyName BrWhite   = "ghost-white"++-- | Human-readable names for item colors. The liquid set.+colorToLiquidName :: Color -> Text+colorToLiquidName Black     = "tarry"+colorToLiquidName Red       = "bloody"+colorToLiquidName Green     = "moldy"+colorToLiquidName Brown     = "muddy"+colorToLiquidName Blue      = "oily"+colorToLiquidName Magenta   = "swirling"+colorToLiquidName Cyan      = "bubbling"+colorToLiquidName White     = "cloudy"+colorToLiquidName AltWhite  = error "colorToLiquidName: illegal color"+colorToLiquidName BrBlack   = "pitchy"+colorToLiquidName BrRed     = "red-speckled"+colorToLiquidName BrGreen   = "sappy"+colorToLiquidName BrYellow  = "golden"+colorToLiquidName BrBlue    = "blue-speckled"+colorToLiquidName BrMagenta = "hazy"+colorToLiquidName BrCyan    = "misty"+colorToLiquidName BrWhite   = "shining"++-- | Human-readable names for item colors. The plain glass set.+colorToGlassPlainName :: Color -> Text+colorToGlassPlainName color = colorToPlainName color <+> "glass"++-- | Human-readable names for item colors. The fancy glass set.+colorToGlassFancyName :: Color -> Text+colorToGlassFancyName color = colorToFancyName color <+> "crystal"++-- | Human-readable names for story item colors.+colorToStoryName :: Color -> Text+colorToStoryName Black     = "unfathomable"+colorToStoryName Red       = "depressing"+colorToStoryName Green     = "confidence-boosting"+colorToStoryName Brown     = "mundane"+colorToStoryName Blue      = "fleeting"+colorToStoryName Magenta   = "complex"+colorToStoryName Cyan      = "wierd"+colorToStoryName White     = "obvious"+colorToStoryName AltWhite  = error "colorToStoryName: illegal color"+colorToStoryName BrBlack   = "inconclusive"+colorToStoryName BrRed     = "troubling"+colorToStoryName BrGreen   = "cherished"+colorToStoryName BrYellow  = "glaring"+colorToStoryName BrBlue    = "profound"+colorToStoryName BrMagenta = "torturous"+colorToStoryName BrCyan    = "peculiar"+colorToStoryName BrWhite   = "explosive"++-- | Simple names for team colors (bright colours preferred).+colorToTeamName :: Color -> Text+colorToTeamName BrBlack   = "black"+colorToTeamName BrRed     = "red"+colorToTeamName BrGreen   = "green"+colorToTeamName BrYellow  = "yellow"+colorToTeamName BrBlue    = "blue"+colorToTeamName BrMagenta = "pink"+colorToTeamName BrCyan    = "cyan"+colorToTeamName BrWhite   = "white"+colorToTeamName c = colorToFancyName c
+ engine-src/Game/LambdaHack/Atomic.hs view
@@ -0,0 +1,22 @@+-- | Atomic game state transformations, their representation and semantics.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic+  ( -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic"+    CmdAtomic(..), UpdAtomic(..), HearMsg(..), SfxAtomic(..), SfxMsg(..)+    -- * Re-exported from "Game.LambdaHack.Atomic.HandleAtomicWrite"+  , handleUpdAtomic+    -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead"+  , PosAtomic(..), posUpdAtomic, posSfxAtomic, iidUpdAtomic, iidSfxAtomic+  , breakUpdAtomic, lidOfPos, seenAtomicCli, seenAtomicSer+    -- * Re-exported from "Game.LambdaHack.Atomic.MonadStateWrite"+  , MonadStateWrite(..), AtomicFail(..)+  ) where++import Prelude ()++import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Atomic.HandleAtomicWrite+import Game.LambdaHack.Atomic.MonadStateWrite+import Game.LambdaHack.Atomic.PosAtomicRead
+ engine-src/Game/LambdaHack/Atomic/CmdAtomic.hs view
@@ -0,0 +1,302 @@+-- | A set of atomic commands shared by client and server.+-- These are the largest building blocks that have no components+-- that can be observed in isolation.+--+-- We try to make atomic commands respect the laws of energy and mass+-- conservation, unless they really can't, e.g., monster spawning.+-- For example item removal from equipment, in isolation, is not an atomic+-- command, but item dropped from equipment to the ground is. This makes+-- it easier to undo the commands. In principle, the commands are the only+-- way to affect the basic game state ('State').+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic.CmdAtomic+  ( CmdAtomic(..), UpdAtomic(..), HearMsg(..), SfxAtomic(..), SfxMsg(..)+  , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumSet as ES+import           Data.Int (Int64)+import qualified System.Random.SplitMix32 as SM++-- Dependence on ClientOptions is an anomaly. Instead, probably the raw+-- remaining commandline should be passed and parsed by the client to extract+-- client and ui options from and singnal an error if anything was left.++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.Analytics+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.PlaceKind as PK+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | Abstract syntax of atomic commands, that is, atomic game state+-- transformations.+data CmdAtomic =+    UpdAtomic UpdAtomic  -- ^ atomic updates+  | SfxAtomic SfxAtomic  -- ^ atomic special effects+  deriving Show++-- TODO: needed in the future, if ever, to save undo information:+--+--  deriving (Show, Eq, Generic)+--+-- instance Binary CmdAtomic++-- | Abstract syntax of atomic updates, that is, atomic commands+-- that really change the 'State'. Most of them are an encoding of a game+-- state diff, though they also carry some intentional hints+-- that help clients determine whether and how to communicate it to players.+data UpdAtomic =+  -- Create/destroy actors and items.+    UpdRegisterItems [(ItemId, Item)]+  | UpdCreateActor ActorId Actor [(ItemId, Item)]+  | UpdDestroyActor ActorId Actor [(ItemId, Item)]+  | UpdCreateItem Bool ItemId Item ItemQuant Container+  | UpdDestroyItem Bool ItemId Item ItemQuant Container+  | UpdSpotActor ActorId Actor+  | UpdLoseActor ActorId Actor+  | UpdSpotItem Bool ItemId ItemQuant Container+  | UpdLoseItem Bool ItemId ItemQuant Container+  | UpdSpotItemBag Bool Container ItemBag+  | UpdLoseItemBag Bool Container ItemBag+  -- Move actors and items.+  | UpdMoveActor ActorId Point Point+  | UpdWaitActor ActorId Watchfulness Watchfulness+  | UpdDisplaceActor ActorId ActorId+  | UpdMoveItem ItemId Int ActorId CStore CStore+  -- Change actor attributes.+  | UpdRefillHP ActorId Int64+  | UpdRefillCalm ActorId Int64+  | UpdTrajectory ActorId (Maybe ([Vector], Speed)) (Maybe ([Vector], Speed))+  -- Change faction attributes.+  | UpdQuitFaction FactionId (Maybe Status) (Maybe Status)+                   (Maybe (FactionAnalytics, GenerationAnalytics))+  | UpdSpotStashFaction Bool FactionId LevelId Point+  | UpdLoseStashFaction Bool FactionId LevelId Point+  | UpdLeadFaction FactionId (Maybe ActorId) (Maybe ActorId)+  | UpdDiplFaction FactionId FactionId Diplomacy Diplomacy+  | UpdDoctrineFaction FactionId Ability.Doctrine Ability.Doctrine+  | UpdAutoFaction FactionId Bool+  | UpdRecordKill ActorId (ContentId ItemKind) Int+  -- Alter map.+  | UpdAlterTile LevelId Point (ContentId TileKind) (ContentId TileKind)+  | UpdAlterExplorable LevelId Int+  | UpdAlterGold Int+  | UpdSearchTile ActorId Point (ContentId TileKind)+  | UpdHideTile ActorId Point (ContentId TileKind)+  | UpdSpotTile LevelId [(Point, ContentId TileKind)]+  | UpdLoseTile LevelId [(Point, ContentId TileKind)]+  | UpdSpotEntry LevelId [(Point, PK.PlaceEntry)]+  | UpdLoseEntry LevelId [(Point, PK.PlaceEntry)]+  | UpdAlterSmell LevelId Point Time Time+  | UpdSpotSmell LevelId [(Point, Time)]+  | UpdLoseSmell LevelId [(Point, Time)]+  -- Assorted.+  | UpdTimeItem ItemId Container ItemTimers ItemTimers+  | UpdAgeGame (ES.EnumSet LevelId)+  | UpdUnAgeGame (ES.EnumSet LevelId)+  | UpdDiscover Container ItemId (ContentId ItemKind) IA.AspectRecord+      -- Here and below @Container@ is only used for presentation+      -- and when @CStash@ is not visible, but the item is, it won't+      -- break anything, because item identification is not registered globally.+  | UpdCover Container ItemId (ContentId ItemKind) IA.AspectRecord+  | UpdDiscoverKind Container ItemKindIx (ContentId ItemKind)+  | UpdCoverKind Container ItemKindIx (ContentId ItemKind)+  | UpdDiscoverAspect Container ItemId IA.AspectRecord+  | UpdCoverAspect Container ItemId IA.AspectRecord+  | UpdDiscoverServer ItemId IA.AspectRecord+  | UpdCoverServer ItemId IA.AspectRecord+  | UpdPerception LevelId Perception Perception+  | UpdRestart FactionId PerLid State Challenge ClientOptions SM.SMGen+  | UpdRestartServer State+  | UpdResume FactionId PerLid+  | UpdResumeServer State+  | UpdKillExit FactionId+  | UpdWriteSave+  | UpdHearFid FactionId (Maybe Int) HearMsg+      -- in @UpdAtomic@ to let AI analyze and count+  | UpdMuteMessages FactionId Bool+  deriving Show++-- | Symbolic representation of text messages about heard noises,+-- sent by server to clients and shown to players and used by AI.+data HearMsg =+    HearUpd UpdAtomic+  | HearStrike (ContentId ItemKind)+  | HearSummon Bool (GroupName ItemKind) Dice.Dice+  | HearCollideTile+  | HearTaunt Text+  deriving Show++-- | Abstract syntax of atomic special effects, that is, atomic commands+-- that only display special effects and don't change 'State' nor client state.+data SfxAtomic =+    SfxStrike ActorId ActorId ItemId+  | SfxRecoil ActorId ActorId ItemId+  | SfxSteal ActorId ActorId ItemId+  | SfxRelease ActorId ActorId ItemId+  | SfxProject ActorId ItemId+  | SfxReceive ActorId ItemId+  | SfxApply ActorId ItemId+  | SfxCheck ActorId ItemId+  | SfxTrigger ActorId LevelId Point (ContentId TileKind)+  | SfxShun ActorId LevelId Point (ContentId TileKind)+  | SfxEffect FactionId ActorId ItemId IK.Effect Int64+  | SfxItemApplied Bool ItemId Container+  | SfxMsgFid FactionId SfxMsg+  | SfxRestart+  | SfxCollideTile ActorId Point+  | SfxTaunt Bool ActorId+  deriving Show++-- | Symbolic representation of text messages sent by server to clients+-- and shown to players.+data SfxMsg =+    SfxUnexpected ReqFailure+  | SfxExpected Text ReqFailure+  | SfxExpectedEmbed ItemId LevelId ReqFailure+  | SfxFizzles ItemId Container+  | SfxNothingHappens ItemId Container+  | SfxNoItemsForTile [[(Int, GroupName ItemKind)]]+  | SfxVoidDetection IK.DetectKind+  | SfxUnimpressed ActorId+  | SfxSummonLackCalm ActorId+  | SfxSummonTooManyOwn ActorId+  | SfxSummonTooManyAll ActorId+  | SfxSummonFailure ActorId+  | SfxLevelNoMore+  | SfxLevelPushed+  | SfxBracedImmune ActorId+  | SfxEscapeImpossible+  | SfxStasisProtects+  | SfxWaterParalysisResisted+  | SfxTransImpossible+  | SfxIdentifyNothing+  | SfxPurposeNothing+  | SfxPurposeTooFew Int Int+  | SfxPurposeUnique+  | SfxPurposeNotCommon+  | SfxRerollNothing+  | SfxRerollNotRandom+  | SfxDupNothing+  | SfxDupUnique+  | SfxDupValuable+  | SfxColdFish+  | SfxReadyGoods+  | SfxTimerExtended ActorId ItemId CStore (Delta Time)+      -- This @CStore@ is only printed, so even @CStash@ is safe.+  | SfxCollideActor ActorId ActorId+  | SfxItemYield ItemId Int LevelId+  deriving Show++undoUpdAtomic :: UpdAtomic -> Maybe UpdAtomic+undoUpdAtomic cmd = case cmd of+  UpdRegisterItems{} -> Nothing  -- harmless and never forgotten+  UpdCreateActor aid body ais -> Just $ UpdDestroyActor aid body ais+  UpdDestroyActor aid body ais -> Just $ UpdCreateActor aid body ais+  UpdCreateItem verbose iid item k c ->+    Just $ UpdDestroyItem verbose iid item k c+  UpdDestroyItem verbose iid item k c ->+    Just $ UpdCreateItem verbose iid item k c+  UpdSpotActor aid body -> Just $ UpdLoseActor aid body+  UpdLoseActor aid body -> Just $ UpdSpotActor aid body+  UpdSpotItem verbose iid k c -> Just $ UpdLoseItem verbose iid k c+  UpdLoseItem verbose iid k c -> Just $ UpdSpotItem verbose iid k c+  UpdSpotItemBag verbose c bag -> Just $ UpdLoseItemBag verbose c bag+  UpdLoseItemBag verbose c bag -> Just $ UpdSpotItemBag verbose c bag+  UpdMoveActor aid fromP toP -> Just $ UpdMoveActor aid toP fromP+  UpdWaitActor aid fromWS toWS -> Just $ UpdWaitActor aid toWS fromWS+  UpdDisplaceActor source target -> Just $ UpdDisplaceActor target source+  UpdMoveItem iid k aid store1 store2 ->+    Just $ UpdMoveItem iid k aid store2 store1+  UpdRefillHP aid n -> Just $ UpdRefillHP aid (-n)+  UpdRefillCalm aid n -> Just $ UpdRefillCalm aid (-n)+  UpdTrajectory aid fromT toT -> Just $ UpdTrajectory aid toT fromT+  UpdQuitFaction fid fromSt toSt manalytics ->+    Just $ UpdQuitFaction fid toSt fromSt manalytics+  UpdSpotStashFaction verbose fid lid pos ->+    Just $ UpdLoseStashFaction verbose fid lid pos+  UpdLoseStashFaction verbose fid lid pos ->+    Just $ UpdSpotStashFaction verbose fid lid pos+  UpdLeadFaction fid source target -> Just $ UpdLeadFaction fid target source+  UpdDiplFaction fid1 fid2 fromDipl toDipl ->+    Just $ UpdDiplFaction fid1 fid2 toDipl fromDipl+  UpdDoctrineFaction fid toT fromT -> Just $ UpdDoctrineFaction fid fromT toT+  UpdAutoFaction fid st -> Just $ UpdAutoFaction fid (not st)+  UpdRecordKill aid ikind k -> Just $ UpdRecordKill aid ikind (-k)+  UpdAlterTile lid p fromTile toTile ->+    Just $ UpdAlterTile lid p toTile fromTile+  UpdAlterExplorable lid delta -> Just $ UpdAlterExplorable lid (-delta)+  UpdAlterGold delta -> Just $ UpdAlterGold (-delta)+  UpdSearchTile aid p toTile -> Just $ UpdHideTile aid p toTile+  UpdHideTile aid p toTile -> Just $ UpdSearchTile aid p toTile+  UpdSpotTile lid ts -> Just $ UpdLoseTile lid ts+  UpdLoseTile lid ts -> Just $ UpdSpotTile lid ts+  UpdSpotEntry lid ts -> Just $ UpdLoseEntry lid ts+  UpdLoseEntry lid ts -> Just $ UpdSpotEntry lid ts+  UpdAlterSmell lid p fromSm toSm -> Just $ UpdAlterSmell lid p toSm fromSm+  UpdSpotSmell lid sms -> Just $ UpdLoseSmell lid sms+  UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms+  UpdTimeItem iid c fromIt toIt -> Just $ UpdTimeItem iid c toIt fromIt+  UpdAgeGame lids -> Just $ UpdUnAgeGame lids+  UpdUnAgeGame lids -> Just $ UpdAgeGame lids+  UpdDiscover c iid ik arItem -> Just $ UpdCover c iid ik arItem+  UpdCover c iid ik arItem -> Just $ UpdDiscover c iid ik arItem+  UpdDiscoverKind c ix ik -> Just $ UpdCoverKind c ix ik+  UpdCoverKind c ix ik -> Just $ UpdDiscoverKind c ix ik+  UpdDiscoverAspect c iid arItem -> Just $ UpdCoverAspect c iid arItem+  UpdCoverAspect c iid arItem -> Just $ UpdDiscoverAspect c iid arItem+  UpdDiscoverServer iid arItem -> Just $ UpdCoverServer iid arItem+  UpdCoverServer iid arItem -> Just $ UpdDiscoverServer iid arItem+  UpdPerception lid outPer inPer -> Just $ UpdPerception lid inPer outPer+  UpdRestart{} -> Just cmd  -- here history ends; change direction+  UpdRestartServer{} -> Just cmd  -- here history ends; change direction+  UpdResume{} -> Nothing+  UpdResumeServer{} -> Nothing+  UpdKillExit{} -> Nothing+  UpdWriteSave -> Nothing+  UpdHearFid{} -> Nothing+  UpdMuteMessages fid b -> Just $ UpdMuteMessages fid $ not b++undoSfxAtomic :: SfxAtomic -> SfxAtomic+undoSfxAtomic cmd = case cmd of+  SfxStrike source target iid -> SfxRecoil source target iid+  SfxRecoil source target iid -> SfxStrike source target iid+  SfxSteal source target iid -> SfxRelease source target iid+  SfxRelease source target iid -> SfxSteal source target iid+  SfxProject aid iid -> SfxReceive aid iid+  SfxReceive aid iid -> SfxProject aid iid+  SfxApply aid iid -> SfxCheck aid iid+  SfxCheck aid iid -> SfxApply aid iid+  SfxTrigger aid lid p tile -> SfxShun aid lid p tile+  SfxShun aid lid p tile -> SfxTrigger aid lid p tile+  SfxEffect{} -> cmd  -- not ideal?+  SfxItemApplied{} -> cmd+  SfxMsgFid{} -> cmd+  SfxRestart -> cmd+  SfxCollideTile{} -> cmd+  SfxTaunt{} -> cmd++undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic+undoCmdAtomic (UpdAtomic cmd) = UpdAtomic <$> undoUpdAtomic cmd+undoCmdAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx
+ engine-src/Game/LambdaHack/Atomic/HandleAtomicWrite.hs view
@@ -0,0 +1,759 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Semantics of atomic commands shared by client and server.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic.HandleAtomicWrite+  ( handleUpdAtomic+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , updRegisterItems, updCreateActor, updDestroyActor+  , updCreateItem, updDestroyItem, updSpotItemBag, updLoseItemBag+  , updMoveActor, updWaitActor, updDisplaceActor, updMoveItem+  , updRefillHP, updRefillCalm+  , updTrajectory, updQuitFaction, updSpotStashFaction, updLoseStashFaction+  , updLeadFaction, updDiplFaction, updDoctrineFaction, updAutoFaction+  , updRecordKill, updAlterTile, updAlterExplorable, updSearchTile+  , updSpotTile, updLoseTile, updAlterSmell, updSpotSmell, updLoseSmell+  , updTimeItem, updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover+  , updDiscoverKind, discoverKind, updCoverKind+  , updDiscoverAspect, discoverAspect, updCoverAspect+  , updDiscoverServer, updCoverServer+  , updRestart, updRestartServer, updResumeServer+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Int (Int64)++import           Game.LambdaHack.Atomic.CmdAtomic+import           Game.LambdaHack.Atomic.MonadStateWrite+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.PlaceKind as PK+import           Game.LambdaHack.Content.TileKind (TileKind, unknownId)+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | The game-state semantics of atomic game commands.+-- There is no corresponding definition for special effects (@SfxAtomic@),+-- because they don't modify 'State'.+--+-- For each of the commands, we are guaranteed that the client,+-- the command is addressed to, perceives all the positions the command+-- affects (as computed by 'Game.LambdaHack.Atomic.PosAtomicRead.posUpdAtomic').+-- In the code for each semantic function we additonally verify+-- the client is aware of any relevant items and/or actors and we throw+-- the @AtomicFail@ exception if it's not.+-- The server keeps copies of all clients' states and, before sending a command+-- to a client, applies it to the client's state copy.+-- If @AtomicFail@ is signalled, the command is ignored for that client.+-- This enables simpler server code that addresses commands to all clients+-- that can see it, even though not all are able to process it.+handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()+handleUpdAtomic cmd = case cmd of+  UpdRegisterItems ais -> updRegisterItems ais+  UpdCreateActor aid body ais -> updCreateActor aid body ais+  UpdDestroyActor aid body ais -> updDestroyActor aid body ais+  UpdCreateItem _ iid item kit c -> updCreateItem iid item kit c+  UpdDestroyItem _ iid item kit c -> updDestroyItem iid item kit c+  UpdSpotActor aid body -> updSpotActor aid body+  UpdLoseActor aid body -> updLoseActor aid body+  UpdSpotItem _ iid kit c -> updSpotItem iid kit c+  UpdLoseItem _ iid kit c -> updLoseItem iid kit c+  UpdSpotItemBag _ c bag -> updSpotItemBag c bag+  UpdLoseItemBag _ c bag -> updLoseItemBag c bag+  UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP+  UpdWaitActor aid fromWS toWS -> updWaitActor aid fromWS toWS+  UpdDisplaceActor source target -> updDisplaceActor source target+  UpdMoveItem iid k aid c1 c2 -> updMoveItem iid k aid c1 c2+  UpdRefillHP aid n -> updRefillHP aid n+  UpdRefillCalm aid n -> updRefillCalm aid n+  UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT+  UpdQuitFaction fid fromSt toSt _ -> updQuitFaction fid fromSt toSt+  UpdSpotStashFaction _ fid lid pos -> updSpotStashFaction fid lid pos+  UpdLoseStashFaction _ fid lid pos -> updLoseStashFaction fid lid pos+  UpdLeadFaction fid source target -> updLeadFaction fid source target+  UpdDiplFaction fid1 fid2 fromDipl toDipl ->+    updDiplFaction fid1 fid2 fromDipl toDipl+  UpdDoctrineFaction fid toT fromT -> updDoctrineFaction fid toT fromT+  UpdAutoFaction fid st -> updAutoFaction fid st+  UpdRecordKill aid ikind k -> updRecordKill aid ikind k+  UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile+  UpdAlterExplorable lid delta -> updAlterExplorable lid delta+  UpdAlterGold delta -> updAlterGold delta+  UpdSearchTile aid p toTile -> updSearchTile aid p toTile+  UpdHideTile{} -> undefined+  UpdSpotTile lid ts -> updSpotTile lid ts+  UpdLoseTile lid ts -> updLoseTile lid ts+  UpdSpotEntry lid ts -> updSpotEntry lid ts+  UpdLoseEntry lid ts -> updLoseEntry lid ts+  UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm+  UpdSpotSmell lid sms -> updSpotSmell lid sms+  UpdLoseSmell lid sms -> updLoseSmell lid sms+  UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt+  UpdAgeGame lids -> updAgeGame lids+  UpdUnAgeGame lids -> updUnAgeGame lids+  UpdDiscover c iid ik arItem -> updDiscover c iid ik arItem+  UpdCover c iid ik arItem -> updCover c iid ik arItem+  UpdDiscoverKind c ix ik -> updDiscoverKind c ix ik+  UpdCoverKind c ix ik -> updCoverKind c ix ik+  UpdDiscoverAspect c iid arItem -> updDiscoverAspect c iid arItem+  UpdCoverAspect c iid arItem -> updCoverAspect c iid arItem+  UpdDiscoverServer iid arItem -> updDiscoverServer iid arItem+  UpdCoverServer iid arItem -> updCoverServer iid arItem+  UpdPerception _ outPer inPer ->+    assert (not (nullPer outPer && nullPer inPer)) (return ())+  UpdRestart _ _ s _ _ _ -> updRestart s+  UpdRestartServer s -> updRestartServer s+  UpdResume{} -> return ()+  UpdResumeServer s -> updResumeServer s+  UpdKillExit{} -> return ()+  UpdWriteSave -> return ()+  UpdHearFid{} -> return ()+  UpdMuteMessages{} -> return ()++-- Actor's items may or may not be already present in @sitemD@,+-- regardless if they are already present otherwise in the dungeon.+-- We re-add them all to save time determining which really need it.+-- If collision occurs, pick the item found on easier level.+updRegisterItems :: MonadStateWrite m => [(ItemId, Item)] -> m ()+updRegisterItems ais = do+  let h item1 item2 =+        assert (itemsMatch item1 item2+                `blame` "inconsistent added items"+                `swith` (item1, item2, ais))+               item2 -- keep the first found level+  forM_ ais $ \(iid, item) -> do+    let f = case jkind item of+          IdentityObvious _ -> id+          IdentityCovered ix _ ->+            updateItemIxMap $ EM.insertWith ES.union ix (ES.singleton iid)+    modifyState $ f . updateItemD (EM.insertWith h iid item)++-- Note: after this command, usually a new leader+-- for the party should be elected (in case this actor is the only one alive).+updCreateActor :: MonadStateWrite m+               => ActorId -> Actor -> [(ItemId, Item)] -> m ()+updCreateActor aid body ais = do+  updRegisterItems ais+  updSpotActor aid body++-- If a leader dies, a new leader should be elected on the server+-- before this command is executed (not checked).+updDestroyActor :: MonadStateWrite m+                => ActorId -> Actor -> [(ItemId, Item)] -> m ()+updDestroyActor aid body ais = do+  -- Assert that actor's items belong to @sitemD@. Do not remove those+  -- that do not appear anywhere else, for simplicity and speed.+  itemD <- getsState sitemD+  let match (iid, item) = itemsMatch (itemD EM.! iid) item+  let !_A = assert (allB match ais `blame` "destroyed actor items not found"+                    `swith` (aid, body, ais, itemD)) ()+  updLoseActor aid body++-- Create a few copies of an item that is already registered for the dungeon+-- (in @sitemRev@ field of @StateServer@).+--+-- Number of copies may be zero, when the item is only created as a sample+-- to let the player know what can potentially be genereated in the dungeon.+updCreateItem :: MonadStateWrite m+              => ItemId -> Item -> ItemQuant -> Container -> m ()+updCreateItem iid item kit c = do+  updRegisterItems [(iid, item)]+  updSpotItem iid kit c++-- Destroy some copies (possibly not all) of an item.+updDestroyItem :: MonadStateWrite m+               => ItemId -> Item -> ItemQuant -> Container -> m ()+updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ do+  -- Do not remove the item from @sitemD@ nor from @sitemRev@+  -- nor from @DiscoveryAspect@, @ItemIxMap@, etc.+  -- It's incredibly costly and not particularly noticeable for the player.+  -- Moreover, copies of the item may reappear in the future+  -- and then we save computation and the player remembers past discovery.+  -- However, assert the item is registered in @sitemD@.+  itemD <- getsState sitemD+  let !_A = assert ((case iid `EM.lookup` itemD of+                        Nothing -> False+                        Just item0 -> itemsMatch item0 item)+                    `blame` "item already removed"+                    `swith` (iid, item, itemD)) ()+  updLoseItem iid kit c++updSpotActor :: MonadStateWrite m => ActorId -> Actor -> m ()+updSpotActor aid body = do+  -- The exception is possible, e.g., when we teleport and so see our actor+  -- at the new location, but also the location is part of new perception,+  -- so @UpdSpotActor@ is sent.+  let f Nothing = Just body+      f (Just b) = assert (body == b `blame` (aid, body, b)) $+        atomicFail $ "actor already added" `showFailure` (aid, body, b)+  modifyState $ updateActorD $ EM.alter f aid+  let g Nothing = Just [aid]+      g (Just l) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        -- Not so much expensive, as doubly impossible.+        assert (aid `notElem` l `blame` "actor already added"+                                `swith` (aid, body, l))+#endif+        (Just $ aid : l)+  let h Nothing = Just aid+      h (Just aid2) = error $ "an actor already present there"+                              `showFailure` (aid, body, aid2)+  updateLevel (blid body) $ if bproj body+                            then updateProjMap (EM.alter g (bpos body))+                            else updateBigMap (EM.alter h (bpos body))+  actorMaxSk <- getsState $ maxSkillsFromActor body+  modifyState $ updateActorMaxSkills $ EM.insert aid actorMaxSk++updLoseActor :: MonadStateWrite m => ActorId -> Actor ->  m ()+updLoseActor aid body = do+  -- Remove actor from @sactorD@.+  let f Nothing = error $ "actor already removed" `showFailure` (aid, body)+      f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body"+                                     `swith` (aid, body, b)) Nothing+  modifyState $ updateActorD $ EM.alter f aid+  let g Nothing = error $ "actor already removed" `showFailure` (aid, body)+      g (Just l) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        -- Not so much expensive, as doubly impossible.+        assert (aid `elem` l `blame` "actor already removed"+                             `swith` (aid, body, l))+#endif+        (let l2 = delete aid l+         in if null l2 then Nothing else Just l2)+  let h Nothing = error $ "actor already removed" `showFailure` (aid, body)+      h (Just _aid2) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        -- Not so much expensive, as doubly impossible.+        assert (aid == _aid2 `blame` "actor already removed"+                             `swith` (aid, body, _aid2))+#endif+        Nothing+  updateLevel (blid body) $ if bproj body+                            then updateProjMap (EM.alter g (bpos body))+                            else updateBigMap (EM.alter h (bpos body))+  modifyState $ updateActorMaxSkills $ EM.delete aid++updSpotItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()+updSpotItem iid kit@(k, _) c = do+  item <- getsState $ getItemBody iid+  when (k > 0) $ do+    insertItemContainer iid kit c+    case c of+      CActor aid store -> when (store `elem` [CEqp, COrgan])+                          $ addItemToActorMaxSkills iid item k aid+      _ -> return ()++updLoseItem :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m ()+updLoseItem iid kit@(k, _) c = assert (k > 0) $ do+  item <- getsState $ getItemBody iid+  deleteItemContainer iid kit c+  case c of+    CActor aid store -> when (store `elem` [CEqp, COrgan])+                        $ addItemToActorMaxSkills iid item (-k) aid+    _ -> return ()++updSpotItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()+updSpotItemBag c bag =+  -- The case of empty bag is for a hack to help identifying sample items.+  unless (EM.null bag) $ do+    insertBagContainer bag c+    case c of+      CActor aid store ->+        when (store `elem` [CEqp, COrgan]) $ do+          itemD <- getsState sitemD+          let ais = map (\iid -> (iid, itemD EM.! iid)) $ EM.keys bag+          forM_ ais $ \(iid, item) ->+            addItemToActorMaxSkills iid item (fst $ bag EM.! iid) aid+      _ -> return ()++updLoseItemBag :: MonadStateWrite m => Container -> ItemBag -> m ()+updLoseItemBag c bag = assert (EM.size bag > 0) $ do+  deleteBagContainer bag c+  -- Do not remove the items from @sitemD@ nor from @sitemRev@,+  -- It's incredibly costly and not noticeable for the player.+  -- However, assert the items are registered in @sitemD@.+  case c of+    CActor aid store ->+      when (store `elem` [CEqp, COrgan]) $ do+        itemD <- getsState sitemD+        let ais = map (\iid -> (iid, itemD EM.! iid)) $ EM.keys bag+        forM_ ais $ \(iid, item) ->+          addItemToActorMaxSkills iid item (- (fst $ bag EM.! iid)) aid+    _ -> return ()++updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m ()+updMoveActor aid fromP toP = assert (fromP /= toP) $ do+  body <- getsState $ getActorBody aid+  let !_A = assert (fromP == bpos body+                    `blame` "unexpected moved actor position"+                    `swith` (aid, fromP, toP, bpos body, body)) ()+      newBody = body {bpos = toP, boldpos = Just fromP}+  updateActor aid $ const newBody+  moveActorMap aid body newBody++updWaitActor :: MonadStateWrite m+             => ActorId -> Watchfulness -> Watchfulness -> m ()+updWaitActor aid fromWS toWS = assert (fromWS /= toWS) $ do+  body <- getsState $ getActorBody aid+  let !_A = assert (fromWS == bwatch body+                    `blame` "unexpected actor wait state"+                    `swith` (aid, fromWS, bwatch body, body)) ()+  updateActor aid $ \b -> b {bwatch = toWS}++updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()+updDisplaceActor source target = assert (source /= target) $ do+  sbody <- getsState $ getActorBody source+  tbody <- getsState $ getActorBody target+  let spos = bpos sbody+      tpos = bpos tbody+      snewBody = sbody {bpos = tpos, boldpos = Just spos}+      tnewBody = tbody {bpos = spos, boldpos = Just tpos}+  updateActor source $ const snewBody+  updateActor target $ const tnewBody+  swapActorMap source sbody target tbody++updMoveItem :: MonadStateWrite m+            => ItemId -> Int -> ActorId -> CStore -> CStore+            -> m ()+updMoveItem iid k aid s1 s2 = assert (k > 0 && s1 /= s2) $ do+  b <- getsState $ getActorBody aid+  bag <- getsState $ getBodyStoreBag b s1+  case iid `EM.lookup` bag of+    Nothing -> error $ "" `showFailure` (iid, k, aid, s1, s2)+    Just (_, it) -> do+      deleteItemActor iid (k, take k it) aid s1+      insertItemActor iid (k, take k it) aid s2+  case s1 of+    CEqp -> case s2 of+      COrgan -> return ()+      _ -> do+        itemBase <- getsState $ getItemBody iid+        addItemToActorMaxSkills iid itemBase (-k) aid+    COrgan -> case s2 of+      CEqp -> return ()+      _ -> do+        itemBase <- getsState $ getItemBody iid+        addItemToActorMaxSkills iid itemBase (-k) aid+    _ ->+      when (s2 `elem` [CEqp, COrgan]) $ do+        itemBase <- getsState $ getItemBody iid+        addItemToActorMaxSkills iid itemBase k aid++updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()+updRefillHP aid nRaw =+  updateActor aid $ \b ->+    -- Make rescue easier by not going into negative HP the first time.+    let newRawHP = bhp b + nRaw+        newHP = if bhp b <= 0 then newRawHP else max 0 newRawHP+        n = newHP - bhp b+    in b { bhp = newHP+         , bhpDelta = let oldD = bhpDelta b+                      in case compare n 0 of+                        EQ -> ResDelta { resCurrentTurn = (0, 0)+                                       , resPreviousTurn = resCurrentTurn oldD }+                        LT -> oldD {resCurrentTurn =+                                      ( fst (resCurrentTurn oldD) + n+                                      , snd (resCurrentTurn oldD) )}+                        GT -> oldD {resCurrentTurn =+                                      ( fst (resCurrentTurn oldD)+                                      , snd (resCurrentTurn oldD) + n )}+         }++updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()+updRefillCalm aid n =+  updateActor aid $ \b ->+    b { bcalm = max 0 $ bcalm b + n+      , bcalmDelta = let oldD = bcalmDelta b+                     in case compare n 0 of+                       EQ -> ResDelta { resCurrentTurn = (0, 0)+                                      , resPreviousTurn = resCurrentTurn oldD }+                       LT -> oldD {resCurrentTurn =+                                     ( fst (resCurrentTurn oldD) + n+                                     , snd (resCurrentTurn oldD) )}+                       GT -> oldD {resCurrentTurn =+                                     ( fst (resCurrentTurn oldD)+                                     , snd (resCurrentTurn oldD) + n )}+      }++updTrajectory :: MonadStateWrite m+              => ActorId+              -> Maybe ([Vector], Speed)+              -> Maybe ([Vector], Speed)+              -> m ()+updTrajectory aid fromT toT = assert (fromT /= toT) $ do+  body <- getsState $ getActorBody aid+  let !_A = assert (fromT == btrajectory body+                    `blame` "unexpected actor trajectory"+                    `swith` (aid, fromT, toT, body)) ()+  updateActor aid $ \b -> b {btrajectory = toT}++updQuitFaction :: MonadStateWrite m+               => FactionId -> Maybe Status -> Maybe Status+               -> m ()+updQuitFaction fid fromSt toSt = do+  let !_A = assert (fromSt /= toSt `blame` (fid, fromSt, toSt)) ()+  fact <- getsState $ (EM.! fid) . sfactionD+  let !_A = assert (fromSt == gquit fact+                    `blame` "unexpected actor quit status"+                    `swith` (fid, fromSt, toSt, fact)) ()+  let adj fa = fa {gquit = toSt}+  updateFaction fid adj++updSpotStashFaction :: MonadStateWrite m+                    => FactionId -> LevelId -> Point -> m ()+updSpotStashFaction fid lid pos = do+  let adj fa = fa {gstash = Just (lid, pos)}+    -- the stash may be outdated, but not empty and it's correct,+    -- because we know stash may be only one, so here it's added,+    -- the old one is removed, despite us not seeing its location;+    -- warning: in this form, this is not reversible, no undo,+    -- so we'd need to add the required @UpdLoseStashFaction@+    -- elsehwere, similarly as @LoseTile@ is added when FOV+    -- reveals that tile is different than expected+  updateFaction fid adj++updLoseStashFaction :: MonadStateWrite m+                    => FactionId -> LevelId -> Point -> m ()+updLoseStashFaction fid lid pos = do+  let adj fa = assert (gstash fa == Just (lid, pos)+                       `blame` "unexpected lack of gstash"+                       `swith` (fid, lid, pos, fa))+               $ fa {gstash = Nothing}+  updateFaction fid adj++-- The previous leader is assumed to be alive.+updLeadFaction :: MonadStateWrite m+               => FactionId+               -> Maybe ActorId+               -> Maybe ActorId+               -> m ()+updLeadFaction fid source target = assert (source /= target) $ do+  fact <- getsState $ (EM.! fid) . sfactionD+  let !_A = assert (fhasPointman (gkind fact)) ()+    -- @PosNone@ ensures this+  mtb <- getsState $ \s -> flip getActorBody s <$> target+  let !_A = assert (maybe True (not . bproj) mtb+                    `blame` (fid, source, target, mtb, fact)) ()+  let !_A = assert (source == gleader fact+                    `blame` "unexpected actor leader"+                    `swith` (fid, source, target, mtb, fact)) ()+  let adj fa = fa {_gleader = target}+  updateFaction fid adj++updDiplFaction :: MonadStateWrite m+               => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()+updDiplFaction fid1 fid2 fromDipl toDipl =+  assert (fid1 /= fid2 && fromDipl /= toDipl) $ do+    fact1 <- getsState $ (EM.! fid1) . sfactionD+    fact2 <- getsState $ (EM.! fid2) . sfactionD+    let !_A =+          assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1)+                  && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2)+                  `blame` "unexpected actor diplomacy status"+                  `swith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) ()+    let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}+    updateFaction fid1 (adj fid2)+    updateFaction fid2 (adj fid1)++updDoctrineFaction :: MonadStateWrite m+                   => FactionId -> Ability.Doctrine -> Ability.Doctrine -> m ()+updDoctrineFaction fid toT fromT = do+  let adj fact = assert (gdoctrine fact == fromT) $ fact {gdoctrine = toT}+  updateFaction fid adj++updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()+updAutoFaction fid st =+  updateFaction fid (\fact ->+    assert (gunderAI fact == not st) $ fact {gunderAI = st})++-- Record a given number (usually just 1, or -1 for undo) of actor kills+-- for score calculation.+updRecordKill :: MonadStateWrite m+              => ActorId -> ContentId ItemKind -> Int -> m ()+updRecordKill aid ikind k = do+  b <- getsState $ getActorBody aid+  let !_A = assert (not (bproj b) `blame` (aid, b))+  let alterKind mn = let n = fromMaybe 0 mn + k+                     in if n == 0 then Nothing else Just n+      adjFact fact = fact {gvictims = EM.alter alterKind ikind+                                      $ gvictims fact}+  updateFaction (bfid b) adjFact+    -- The death of a dominated actor counts as the dominating faction's loss+    -- for score purposes, so human nor AI can't treat such actor as disposable,+    -- which means domination will not be as cruel, as frustrating,+    -- as it could be and there is a higher chance of getting back alive+    -- the actor, the human player has grown attached to.++-- Alter an attribute (actually, the only, the defining attribute)+-- of a visible tile. This is similar to e.g., @UpdTrajectory@.+--+-- Removing and creating embedded items when altering a tile+-- is done separately via @UpdCreateItem@ and @UpdDestroyItem@.+updAlterTile :: MonadStateWrite m+             => LevelId -> Point -> ContentId TileKind -> ContentId TileKind+             -> m ()+updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do+  COps{coTileSpeedup} <- getsState scops+  lvl <- getLevel lid+  let t = lvl `at` p+  if t /= fromTile+  then atomicFail "terrain to modify is different than assumed"+  else do+    let adj ts = ts PointArray.// [(p, toTile)]+    updateLevel lid $ updateTile adj+    case ( Tile.isExplorable coTileSpeedup fromTile+         , Tile.isExplorable coTileSpeedup toTile ) of+      (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl2 + 1}+      (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl2 - 1}+      _ -> return ()++updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m ()+updAlterExplorable lid delta = assert (delta /= 0) $+  updateLevel lid $ \lvl -> lvl {lexpl = lexpl lvl + delta}++updAlterGold :: MonadStateWrite m => Int -> m ()+updAlterGold delta = assert (delta /= 0) $+  modifyState $ updateGold (+ delta)++-- Showing to the client the embedded items, if any, is done elsewhere.+updSearchTile :: MonadStateWrite m+              => ActorId -> Point -> ContentId TileKind -> m ()+updSearchTile aid p toTile = do+  COps{cotile} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let t = lvl `at` p+  if t == toTile+  then atomicFail "tile already searched"+  else assert (Just t == Tile.hideAs cotile toTile) $ do+    updLoseTile (blid b) [(p, t)]+    updSpotTile (blid b) [(p, toTile)]  -- not the hidden version this one time++-- Notice previously invisible tiles. This is done in bulk,+-- because it often involves dozens of tiles per move.+-- We verify that the old tiles at the positions in question+-- are indeed unknown.+updSpotTile :: MonadStateWrite m+            => LevelId -> [(Point, ContentId TileKind)] -> m ()+updSpotTile lid ts = assert (not $ null ts) $ do+  COps{coTileSpeedup} <- getsState scops+  let unk tileMap (p, _) = tileMap PointArray.! p == unknownId+      adj tileMap = assert (allB (unk tileMap) ts)+                    $ tileMap PointArray.// ts+  updateLevel lid $ updateTile adj+  let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $+        updateLevel lid $ \lvl -> lvl {lseen = lseen lvl + 1}+  mapM_ f ts++-- Stop noticing previously visible tiles. It verifies+-- the state of the tiles before wiping them out.+updLoseTile :: MonadStateWrite m+            => LevelId -> [(Point, ContentId TileKind)] -> m ()+updLoseTile lid ts = assert (not $ null ts) $ do+  COps{coTileSpeedup} <- getsState scops+  let matches tileMap (p, ov) = tileMap PointArray.! p == ov+      tu = map (second (const unknownId)) ts+      adj tileMap = assert (allB (matches tileMap) ts)+                    $ tileMap PointArray.// tu+  updateLevel lid $ updateTile adj+  let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $+        updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}+  mapM_ f ts++updSpotEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()+updSpotEntry lid ts = assert (not $ null ts) $ do+  let alt en Nothing = Just en+      alt en (Just oldEn) = atomicFail $ "entry already added"+                                         `showFailure` (lid, ts, en, oldEn)+      f (p, en) = EM.alter (alt en) p+      upd m = foldr f m ts+  updateLevel lid $ updateEntry upd++updLoseEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()+updLoseEntry lid ts = assert (not $ null ts) $ do+  let alt en Nothing = error $ "entry already removed"+                               `showFailure` (lid, ts, en)+      alt en (Just oldEn) =+        assert (en == oldEn `blame` "unexpected lost entry"+                            `swith` (lid, ts, en, oldEn)) Nothing+      f (p, en) = EM.alter (alt en) p+      upd m = foldr f m ts+  updateLevel lid $ updateEntry upd++updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()+updAlterSmell lid p fromSm' toSm' = do+  let fromSm = if fromSm' == timeZero then Nothing else Just fromSm'+      toSm = if toSm' == timeZero then Nothing else Just toSm'+      alt sm = assert (sm == fromSm `blame` "unexpected tile smell"+                                    `swith` (lid, p, fromSm, toSm, sm)) toSm+  updateLevel lid $ updateSmell $ EM.alter alt p++updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()+updSpotSmell lid sms = assert (not $ null sms) $ do+  let alt sm Nothing = Just sm+      alt sm (Just oldSm) = error $ "smell already added"+                                    `showFailure` (lid, sms, sm, oldSm)+      f (p, sm) = EM.alter (alt sm) p+      upd m = foldr f m sms+  updateLevel lid $ updateSmell upd++updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()+updLoseSmell lid sms = assert (not $ null sms) $ do+  let alt sm Nothing = error $ "smell already removed"+                               `showFailure` (lid, sms, sm)+      alt sm (Just oldSm) =+        assert (sm == oldSm `blame` "unexpected lost smell"+                            `swith` (lid, sms, sm, oldSm)) Nothing+      f (p, sm) = EM.alter (alt sm) p+      upd m = foldr f m sms+  updateLevel lid $ updateSmell upd++updTimeItem :: MonadStateWrite m+            => ItemId -> Container -> ItemTimers -> ItemTimers+            -> m ()+updTimeItem iid c fromIt toIt = assert (fromIt /= toIt) $ do+  bag <- getsState $ getContainerBag c+  case iid `EM.lookup` bag of+    Just (k, it) -> do+      let !_A1 = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) ()+          !_A2 = assert (length toIt <= k `blame` (k, toIt, iid, c, fromIt)) ()+      deleteItemContainer iid (k, fromIt) c+      insertItemContainer iid (k, toIt) c+    Nothing -> error $ "" `showFailure` (bag, iid, c, fromIt, toIt)++updAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()+updAgeGame lids = do+  modifyState $ updateTime $ flip timeShift (Delta timeClip)+  mapM_ (ageLevel (Delta timeClip)) $ ES.elems lids++updUnAgeGame :: MonadStateWrite m => ES.EnumSet LevelId -> m ()+updUnAgeGame lids = do+  modifyState $ updateTime $ flip timeShift (timeDeltaReverse $ Delta timeClip)+  mapM_ (ageLevel (timeDeltaReverse $ Delta timeClip)) $ ES.elems lids++ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m ()+ageLevel delta lid =+  updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta}++updDiscover :: MonadStateWrite m+            => Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord+            -> m ()+updDiscover _c iid ik arItem = do+  itemD <- getsState sitemD+  COps{coItemSpeedup} <- getsState scops+  let kmIsConst = IA.kmConst $ getKindMean ik coItemSpeedup+  discoKind <- getsState sdiscoKind+  let discoverAtMostAspect = do+        discoAspect <- getsState sdiscoAspect+        if kmIsConst || iid `EM.member` discoAspect+        then atomicFail "item already fully discovered"+        else discoverAspect iid arItem+  case EM.lookup iid itemD of+    Nothing -> atomicFail "discovered item unheard of"+    Just item -> case jkind item of+      IdentityObvious _ -> discoverAtMostAspect+      IdentityCovered ix _ik -> case EM.lookup ix discoKind of+        Just{} -> discoverAtMostAspect+        Nothing -> do+          discoverKind ix ik+          unless kmIsConst $ discoverAspect iid arItem+  resetActorMaxSkills++updCover :: Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord -> m ()+updCover _c _iid _ik _arItem = undefined++updDiscoverKind :: MonadStateWrite m+                => Container -> ItemKindIx -> ContentId ItemKind -> m ()+updDiscoverKind _c ix kmKind = do+  discoKind <- getsState sdiscoKind+  if ix `EM.member` discoKind+  then atomicFail "item kind already discovered"+  else do+    discoverKind ix kmKind+    resetActorMaxSkills++discoverKind :: MonadStateWrite m => ItemKindIx -> ContentId ItemKind -> m ()+discoverKind ix kindId = do+  let f Nothing = Just kindId+      f Just{} = error $ "already discovered" `showFailure` (ix, kindId)+  modifyState $ updateDiscoKind $ \discoKind1 ->+    EM.alter f ix discoKind1++updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()+updCoverKind _c _ix _ik = undefined++updDiscoverAspect :: MonadStateWrite m+                  => Container -> ItemId -> IA.AspectRecord -> m ()+updDiscoverAspect _c iid arItem = do+  COps{coItemSpeedup} <- getsState scops+  itemD <- getsState sitemD+  case EM.lookup iid itemD of+    Nothing -> atomicFail "discovered item unheard of"+    Just item -> do+      -- Here the kind information is exact, hence @getItemKindIdServer@.+      kindId <- getsState $ getItemKindIdServer item+      discoAspect <- getsState sdiscoAspect+      let kmIsConst = IA.kmConst $ getKindMean kindId coItemSpeedup+      if kmIsConst || iid `EM.member` discoAspect+      then atomicFail "item arItem already discovered"+      else do+        discoverAspect iid arItem+        resetActorMaxSkills++discoverAspect :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()+discoverAspect iid arItem = do+  let f Nothing = Just arItem+      f Just{} = error $ "already discovered" `showFailure` (iid, arItem)+  -- At this point we know the item is not @kmConst@.+  modifyState $ updateDiscoAspect $ \discoAspect1 ->+    EM.alter f iid discoAspect1++updCoverAspect :: Container -> ItemId -> IA.AspectRecord -> m ()+updCoverAspect _c _iid _arItem = undefined++updDiscoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()+updDiscoverServer iid arItem =+  modifyState $ updateDiscoAspect $ \discoAspect1 ->+    EM.insert iid arItem discoAspect1++updCoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()+updCoverServer iid arItem =+  modifyState $ updateDiscoAspect $ \discoAspect1 ->+    assert (discoAspect1 EM.! iid == arItem)+    $ EM.delete iid discoAspect1++-- This is ever run only on clients.+updRestart :: MonadStateWrite m => State -> m ()+updRestart = putState++-- This is ever run only on the server.+updRestartServer :: MonadStateWrite m => State -> m ()+updRestartServer = putState++-- This is ever run only on the server.+updResumeServer :: MonadStateWrite m => State -> m ()+updResumeServer = putState
+ engine-src/Game/LambdaHack/Atomic/MonadStateWrite.hs view
@@ -0,0 +1,361 @@+-- | The monad for writing to the main game state.+module Game.LambdaHack.Atomic.MonadStateWrite+  ( MonadStateWrite(..), AtomicFail(..), atomicFail+  , updateLevel, updateActor, updateFaction+  , moveActorMap, swapActorMap+  , insertBagContainer, insertItemContainer, insertItemActor+  , deleteBagContainer, deleteItemContainer, deleteItemActor+  , itemsMatch, addItemToActorMaxSkills, resetActorMaxSkills+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , insertItemFloor, insertItemEmbed+  , insertItemOrgan, insertItemEqp, insertItemStash+  , deleteItemFloor, deleteItemEmbed+  , deleteItemOrgan, deleteItemEqp, deleteItemStash+  , rmFromBag+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Exception as Ex+import qualified Data.EnumMap.Strict as EM+import           Data.Key (mapWithKeyM_)++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | The monad for writing to the main game state. Atomic updates (@UpdAtomic@)+-- are given semantics in this monad.+class MonadStateRead m => MonadStateWrite m where+  modifyState :: (State -> State) -> m ()+  putState :: State -> m ()++-- | Exception signifying that atomic action failed because+-- the information it carries is inconsistent with the client's state,+-- (e.g., because the client knows too little to understand the command+-- or already deduced the state change from earlier commands+-- or is confused, amnesiac or sees illusory actors or tiles).+-- Whenever we know the failure is logically impossible,+-- we don't throw the @AtomicFail@ exception, but insert a normal assertion+-- or @error@ call, which are never caught nor handled.+newtype AtomicFail = AtomicFail String+  deriving Show++instance Ex.Exception AtomicFail++atomicFail :: String -> a+atomicFail = Ex.throw . AtomicFail++-- INLIning offers no speedup, increases alloc and binary size.+-- EM.alter not necessary, because levels not removed, so little risk+-- of adjusting at absent index.+updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m ()+updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid++-- INLIning doesn't help despite probably canceling the alt indirection.+-- perhaps it's applied automatically.+updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()+updateActor aid f = do+  let alt Nothing = error $ "no body to update" `showFailure` aid+      alt (Just b) = Just $ f b+  modifyState $ updateActorD $ EM.alter alt aid++updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m ()+updateFaction fid f = do+  let alt Nothing = error $ "no faction to update" `showFailure` fid+      alt (Just fact) = Just $ f fact+  modifyState $ updateFactionD $ EM.alter alt fid++moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m ()+moveActorMap aid body newBody = do+  let rmBig Nothing = error $ "actor already removed"+                              `showFailure` (aid, body)+      rmBig (Just _aid2) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        assert (aid == _aid2 `blame` "actor already removed"+                             `swith` (aid, body, _aid2))+#endif+        Nothing+      addBig Nothing = Just aid+      addBig (Just aid2) = error $ "an actor already present there"+                                   `showFailure` (aid, body, aid2)+      updBig = EM.alter addBig (bpos newBody)+               . EM.alter rmBig (bpos body)+  let rmProj Nothing = error $ "actor already removed"+                               `showFailure` (aid, body)+      rmProj (Just l) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        assert (aid `elem` l `blame` "actor already removed"+                             `swith` (aid, body, l))+#endif+        (let l2 = delete aid l+         in if null l2 then Nothing else Just l2)+      addProj Nothing = Just [aid]+      addProj (Just l) = Just $ aid : l+      updProj = EM.alter addProj (bpos newBody)+                . EM.alter rmProj (bpos body)+  updateLevel (blid body) $ if bproj body+                            then updateProjMap updProj+                            else updateBigMap updBig++swapActorMap :: MonadStateWrite m+             => ActorId -> Actor -> ActorId -> Actor -> m ()+swapActorMap source sbody target tbody = do+  let addBig aid1 aid2 Nothing =+        error $ "actor already removed"+                `showFailure` (aid1, aid2, source, sbody, target, tbody)+      addBig _aid1 aid2 (Just _aid) =+#ifdef WITH_EXPENSIVE_ASSERTIONS+        assert (_aid == _aid1 `blame` "wrong actor present"+                              `swith` (_aid, _aid1, aid2, sbody, tbody))+#endif+        (Just aid2)+      updBig = EM.alter (addBig source target) (bpos sbody)+               . EM.alter (addBig target source) (bpos tbody)+  if not (bproj sbody) && not (bproj tbody)+  then updateLevel (blid sbody) $ updateBigMap updBig+  else do+    moveActorMap source sbody tbody+    moveActorMap target tbody sbody++insertBagContainer :: MonadStateWrite m+                   => ItemBag -> Container -> m ()+insertBagContainer bag c = case c of+  CFloor lid pos -> do+    let alt Nothing = Just bag+        alt (Just bag2) = atomicFail $ "floor bag not empty"+                                       `showFailure` (bag2, lid, pos, bag)+    updateLevel lid $ updateFloor $ EM.alter alt pos+  CEmbed lid pos -> do+    let alt Nothing = Just bag+        alt (Just bag2) = atomicFail $ "embed bag not empty"+                                       `showFailure` (bag2, lid, pos, bag)+    updateLevel lid $ updateEmbed $ EM.alter alt pos+  CActor aid store ->+    -- Very unlikely case, so we prefer brevity over performance.+    mapWithKeyM_ (\iid kit -> insertItemActor iid kit aid store) bag+  CTrunk{} -> return ()++insertItemContainer :: MonadStateWrite m+                    => ItemId -> ItemQuant -> Container -> m ()+insertItemContainer iid kit c = case c of+  CFloor lid pos -> insertItemFloor iid kit lid pos+  CEmbed lid pos -> insertItemEmbed iid kit lid pos+  CActor aid store -> insertItemActor iid kit aid store+  CTrunk{} -> return ()++-- New @kit@ lands at the front of the list.+insertItemFloor :: MonadStateWrite m+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+insertItemFloor iid kit lid pos =+  let bag = EM.singleton iid kit+      mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag+  in updateLevel lid $ updateFloor mergeBag++insertItemEmbed :: MonadStateWrite m+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+insertItemEmbed iid kit lid pos =+  let bag = EM.singleton iid kit+      mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag+  in updateLevel lid $ updateEmbed mergeBag++insertItemActor :: MonadStateWrite m+                => ItemId -> ItemQuant -> ActorId -> CStore -> m ()+insertItemActor iid kit aid cstore = case cstore of+  CGround -> do+    b <- getsState $ getActorBody aid+    insertItemFloor iid kit (blid b) (bpos b)+  COrgan -> insertItemOrgan iid kit aid+  CEqp -> insertItemEqp iid kit aid+  CStash -> do+    b <- getsState $ getActorBody aid+    insertItemStash iid kit (bfid b)++-- We assume @Meleeable@ and @Benign@ are never secret and so we don't need+-- to fix the weapon counts when the item is identified later on.+insertItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+insertItemOrgan iid kit@(k, _) aid = do+  arItem <- getsState $ aspectRecordFromIid iid+  let bag = EM.singleton iid kit+      upd = EM.unionWith mergeItemQuant bag+  updateActor aid $ \b ->+    b { borgan = upd (borgan b)+      , bweapon = if IA.checkFlag Ability.Meleeable arItem+                  then bweapon b + k+                  else bweapon b+      , bweapBenign = if IA.checkFlag Ability.Meleeable arItem+                         && IA.checkFlag Ability.Benign arItem+                      then bweapBenign b + k+                      else bweapBenign b }++insertItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+insertItemEqp iid kit@(k, _) aid = do+  arItem <- getsState $ aspectRecordFromIid iid+  let bag = EM.singleton iid kit+      upd = EM.unionWith mergeItemQuant bag+  updateActor aid $ \b ->+    b { beqp = upd (beqp b)+      , bweapon = if IA.checkFlag Ability.Meleeable arItem+                  then bweapon b + k+                  else bweapon b+      , bweapBenign = if IA.checkFlag Ability.Meleeable arItem+                         && IA.checkFlag Ability.Benign arItem+                      then bweapBenign b + k+                      else bweapBenign b }++insertItemStash :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m ()+insertItemStash iid kit fid = do+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! fid+  case mstash of+    Just (lid, pos) -> insertItemFloor iid kit lid pos+      -- can't be inserted into outdated or unseen stash position,+      -- because such commands are visible only when the stash position is+      -- and so @gstash@ points at the correct one, thanks to @atomicRemember@+    Nothing -> error $ "" `showFailure` (iid, kit, fid)++deleteBagContainer :: MonadStateWrite m+                   => ItemBag -> Container -> m ()+deleteBagContainer bag c = case c of+  CFloor lid pos -> do+    let alt Nothing = atomicFail $ "floor bag already empty"+                                   `showFailure` (lid, pos, bag)+        alt (Just bag2) = assert (bag == bag2) Nothing+    updateLevel lid $ updateFloor $ EM.alter alt pos+  CEmbed lid pos -> do+    let alt Nothing = atomicFail $ "embed bag already empty"+                                   `showFailure` (lid, pos, bag)+        alt (Just bag2) = assert (bag == bag2 `blame` (bag, bag2)) Nothing+    updateLevel lid $ updateEmbed $ EM.alter alt pos+  CActor aid store ->+    -- Very unlikely case, so we prefer brevity over performance.+    mapWithKeyM_ (\iid kit -> deleteItemActor iid kit aid store) bag+  CTrunk{} -> error $ "" `showFailure` c++deleteItemContainer :: MonadStateWrite m+                    => ItemId -> ItemQuant -> Container -> m ()+deleteItemContainer iid kit c = case c of+  CFloor lid pos -> deleteItemFloor iid kit lid pos+  CEmbed lid pos -> deleteItemEmbed iid kit lid pos+  CActor aid store -> deleteItemActor iid kit aid store+  CTrunk{} -> error $ "" `showFailure` c++deleteItemFloor :: MonadStateWrite m+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+deleteItemFloor iid kit lid pos =+  let rmFromFloor (Just bag) =+        let nbag = rmFromBag kit iid bag+        in if EM.null nbag then Nothing else Just nbag+      rmFromFloor Nothing = error $ "item already removed"+                                    `showFailure` (iid, kit, lid, pos)+  in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos++deleteItemEmbed :: MonadStateWrite m+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+deleteItemEmbed iid kit lid pos =+  let rmFromFloor (Just bag) =+        let nbag = rmFromBag kit iid bag+        in if EM.null nbag then Nothing else Just nbag+      rmFromFloor Nothing = error $ "item already removed"+                                    `showFailure` (iid, kit, lid, pos)+  in updateLevel lid $ updateEmbed $ EM.alter rmFromFloor pos++deleteItemActor :: MonadStateWrite m+                => ItemId -> ItemQuant -> ActorId -> CStore -> m ()+deleteItemActor iid kit aid cstore = case cstore of+  CGround -> do+    b <- getsState $ getActorBody aid+    deleteItemFloor iid kit (blid b) (bpos b)+  COrgan -> deleteItemOrgan iid kit aid+  CEqp -> deleteItemEqp iid kit aid+  CStash -> do+    b <- getsState $ getActorBody aid+    deleteItemStash iid kit (bfid b)++deleteItemOrgan :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+deleteItemOrgan iid kit@(k, _) aid = do+  arItem <- getsState $ aspectRecordFromIid iid+  updateActor aid $ \b ->+    b { borgan = rmFromBag kit iid (borgan b)+      , bweapon = if IA.checkFlag Ability.Meleeable arItem+                  then bweapon b - k+                  else bweapon b+      , bweapBenign = if IA.checkFlag Ability.Meleeable arItem+                         && IA.checkFlag Ability.Benign arItem+                      then bweapBenign b - k+                      else bweapBenign b }++deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+deleteItemEqp iid kit@(k, _) aid = do+  arItem <- getsState $ aspectRecordFromIid iid+  updateActor aid $ \b ->+    b { beqp = rmFromBag kit iid (beqp b)+      , bweapon = if IA.checkFlag Ability.Meleeable arItem+                  then bweapon b - k+                  else bweapon b+      , bweapBenign = if IA.checkFlag Ability.Meleeable arItem+                         && IA.checkFlag Ability.Benign arItem+                      then bweapBenign b - k+                      else bweapBenign b }++deleteItemStash :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m ()+deleteItemStash iid kit fid = do+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! fid+  case mstash of+    Just (lid, pos) -> deleteItemFloor iid kit lid pos+      -- can't be deleted from an outdated or unseen stash position,+      -- because such commands are visible only when the stash position is+      -- and so @gstash@ points at the correct one, thanks to @atomicRemember@+    Nothing -> error $ "" `showFailure` (iid, kit, fid)++-- Removing the part of the kit from the back of the list,+-- so that @DestroyItem kit (CreateItem kit x) == x@.+rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag+rmFromBag kit@(k, rmIt) iid bag =+  let rfb Nothing = error $ "rm from empty slot" `showFailure` (k, iid, bag)+      rfb (Just (n, it)) =+        case compare n k of+          LT -> error $ "rm more than there is"+                        `showFailure` (n, kit, iid, bag)+          EQ -> assert (rmIt == it `blame` (rmIt, it, n, kit, iid, bag)) Nothing+          GT -> assert (rmIt == take k it+                        `blame` (rmIt, take k it, n, kit, iid, bag))+                $ Just (n - k, take (n - k) it)+  in EM.alter rfb iid bag++itemsMatch :: Item -> Item -> Bool+itemsMatch item1 item2 =+  jkind item1 == jkind item2+  -- Note that nothing else needs to be the same, since items are merged+  -- and clients have different views on dungeon items than the server.++addItemToActorMaxSkills :: MonadStateWrite m+                        => ItemId -> Item -> Int -> ActorId -> m ()+addItemToActorMaxSkills iid itemBase k aid = do+  arItem <- getsState $ aspectRecordFromItem iid itemBase+  let f actorMaxSk =+        Ability.sumScaledSkills [(actorMaxSk, 1), (IA.aSkills arItem, k)]+  modifyState $ updateActorMaxSkills $ EM.adjust f aid++resetActorMaxSkills :: MonadStateWrite m => m ()+resetActorMaxSkills = do+  -- Each actor's equipment and organs would need to be inspected,+  -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new,+  -- and then aspect record updated, so it's simpler and not much more+  -- expensive to generate new sactorMaxSkills. Optimize only after profiling.+  -- Also note this doesn't get invoked on the server, because it bails out+  -- earlier, upon noticing the item is already fully known.+  actorMaxSk <- getsState maxSkillsInDungeon+  modifyState $ updateActorMaxSkills $ const actorMaxSk
+ engine-src/Game/LambdaHack/Atomic/PosAtomicRead.hs view
@@ -0,0 +1,492 @@+-- | Representation and computation of visiblity of atomic commands+-- by clients.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic.PosAtomicRead+  ( PosAtomic(..), posUpdAtomic, posSfxAtomic, iidUpdAtomic, iidSfxAtomic+  , breakUpdAtomic, lidOfPos, seenAtomicCli, seenAtomicSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , pointsProjBody, posProjBody, singleAid, doubleAid+  , singleContainerStash, singleContainerActor+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Types+import Game.LambdaHack.Definition.Defs++-- All functions here that take an atomic action are executed+-- in the state just before the action is executed.++-- | The type representing visibility of atomic commands to factions,+-- based on the position of the command, etc. Note that the server+-- sees and smells all positions. Also note that hearing is not covered+-- because it gives very restricted information, so hearing doesn't equal+-- seeing (and we assume smelling actors get lots of data from smells).+data PosAtomic =+    PosSight LevelId [Point]    -- ^ whomever sees all the positions, notices+  | PosFidAndSight FactionId LevelId [Point]+                                -- ^ observers and the faction notice+  | PosSmell LevelId [Point]    -- ^ whomever smells all the positions, notices+  | PosSightLevels [(LevelId, Point)]+                                -- ^ whomever sees all the positions, notices+  | PosFid FactionId            -- ^ only the faction notices, server doesn't+  | PosFidAndSer FactionId      -- ^ faction and server notices+  | PosSer                      -- ^ only the server notices+  | PosAll                      -- ^ everybody notices+  | PosNone                     -- ^ never broadcasted, but sent manually+  deriving (Show, Eq)++-- | Produce the positions where the atomic update takes place or, more+-- generally, the conditions under which the update can be noticed by+-- a client.+--+-- The goal of this mechanics is to ensure that atomic commands involving+-- some positions visible by a client convey similar information as the client+-- would get by directly observing the changes+-- of the portion of server state limited to the visible positions.+-- Consequently, when the visible commands are later applied+-- to the client's state, the state stays consistent+-- --- in sync with the server state and correctly limited by visiblity.+-- There is some wiggle room both in what "in sync" and+-- "visible" means and how they propagate through time.+--+-- E.g., @UpdDisplaceActor@ in a black room between two enemy actors,+-- with only one actor carrying a 0-radius light would not be+-- distinguishable by looking at the state (or the screen) from @UpdMoveActor@+-- of the illuminated actor, hence such @UpdDisplaceActor@ should not be+-- observable, but @UpdMoveActor@ in similar cotext would be+-- (or the former should be perceived as the latter).+-- However, to simplify, we assign as strict visibility+-- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back+-- to @UpdSpotActor@ (which provides minimal information that does not+-- contradict state) if the visibility is lower.+posUpdAtomic :: MonadStateRead m => UpdAtomic -> m PosAtomic+posUpdAtomic cmd = case cmd of+  UpdRegisterItems{} -> return PosNone+  UpdCreateActor _ body _ -> return $! posProjBody body+  UpdDestroyActor _ body _ -> return $! posProjBody body+  UpdCreateItem _ _ _ _ c -> singleContainerStash c+  UpdDestroyItem _ _ _ _ c -> singleContainerStash c+  UpdSpotActor _ body -> return $! posProjBody body+  UpdLoseActor _ body -> return $! posProjBody body+  UpdSpotItem _ _ _ c -> singleContainerStash c+  UpdLoseItem _ _ _ c -> singleContainerStash c+  UpdSpotItemBag _ c _ -> singleContainerStash c+  UpdLoseItemBag _ c _ -> singleContainerStash c+  UpdMoveActor aid fromP toP -> do+    b <- getsState $ getActorBody aid+    -- Non-projectile actors are never totally isolated from environment;+    -- they hear, feel air movement, etc.+    return $! pointsProjBody b [fromP, toP]+  UpdWaitActor aid _ _ -> singleAid aid+  UpdDisplaceActor source target -> doubleAid source target+  UpdMoveItem _ _ aid cstore1 cstore2 -> do+    b <- getsState $ getActorBody aid+    mlidPos1 <- lidPosOfStash b cstore1+    mlidPos2 <- lidPosOfStash b cstore2+    let mlidPos = mlidPos1 `mplus` mlidPos2+    return $! maybe (posProjBody b)+                    (\lidPos -> PosSightLevels [lidPos, (blid b, bpos b)])+                    mlidPos+  UpdRefillHP aid _ -> singleAid aid+  UpdRefillCalm aid _ -> singleAid aid+  UpdTrajectory aid _ _ -> singleAid aid+  UpdQuitFaction{} -> return PosAll+  UpdSpotStashFaction _ fid lid pos -> return $! PosFidAndSight fid lid [pos]+  UpdLoseStashFaction _ fid lid pos -> return $! PosFidAndSight fid lid [pos]+  UpdLeadFaction fid _ _ -> return $! PosFidAndSer fid+  UpdDiplFaction{} -> return PosAll+  UpdDoctrineFaction{} -> return PosAll  -- make faction lore fun+  UpdAutoFaction{} -> return PosAll+  UpdRecordKill aid _ _ -> singleAid aid+  UpdAlterTile lid p _ _ -> return $! PosSight lid [p]+  UpdAlterExplorable{} -> return PosAll+    -- Can't have @PosSight@, because we'd end up with many accessible+    -- unknown tiles, but the game reporting 'all seen'.+  UpdAlterGold{} -> return PosAll+  UpdSearchTile aid p _ -> do+    b <- getsState $ getActorBody aid+    return $! pointsProjBody b [bpos b, p]+  UpdHideTile aid p _ -> do+    b <- getsState $ getActorBody aid+    return $! pointsProjBody b [bpos b, p]+  UpdSpotTile lid ts -> do+    let ps = map fst ts+    return $! PosSight lid ps+  UpdLoseTile lid ts -> do+    let ps = map fst ts+    return $! PosSight lid ps+  UpdSpotEntry lid ts -> do+    let ps = map fst ts+    return $! PosSight lid ps+  UpdLoseEntry lid ts -> do+    let ps = map fst ts+    return $! PosSight lid ps+  UpdAlterSmell lid p _ _ -> return $! PosSmell lid [p]+  UpdSpotSmell lid sms -> do+    let ps = map fst sms+    return $! PosSmell lid ps+  UpdLoseSmell lid sms -> do+    let ps = map fst sms+    return $! PosSmell lid ps+  UpdTimeItem _ c _ _ -> singleContainerStash c+  UpdAgeGame _ -> return PosAll+  UpdUnAgeGame _ -> return PosAll+  UpdDiscover c _ _ _ -> singleContainerActor c+    -- This implies other factions applying items from their inventory,+    -- when we can't see the position of the stash, won't Id the item+    -- for us, even when notice item usage. Thrown items will Id, though,+    -- just as triggering items from the floor or embedded items.+  UpdCover c _ _ _ -> singleContainerActor c+  UpdDiscoverKind c _ _ -> singleContainerActor c+  UpdCoverKind c _ _ -> singleContainerActor c+  UpdDiscoverAspect c _ _ -> singleContainerActor c+  UpdCoverAspect c _ _ -> singleContainerActor c+  UpdDiscoverServer{} -> return PosSer+  UpdCoverServer{} -> return PosSer+  UpdPerception{} -> return PosNone+  UpdRestart fid _ _ _ _ _ -> return $! PosFid fid+  UpdRestartServer _ -> return PosSer+  UpdResume _ _ -> return PosNone+  UpdResumeServer _ -> return PosSer+  UpdKillExit fid -> return $! PosFid fid+  UpdWriteSave -> return PosAll+  UpdHearFid fid _ _ -> return $! PosFid fid+  UpdMuteMessages fid _ -> return $! PosFid fid++-- | Produce the positions where the atomic special effect takes place.+posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic+posSfxAtomic cmd = case cmd of+  SfxStrike _ target _ -> singleAid target+  SfxRecoil _ target _ -> singleAid target+  SfxSteal _ target _ -> singleAid target+  SfxRelease _ target _ -> singleAid target+  SfxProject aid _ -> singleAid aid+  SfxReceive aid _ -> singleAid aid+  SfxApply aid _ -> singleAid aid+  SfxCheck aid _ -> singleAid aid+  SfxTrigger aid lid p _ -> do+    body <- getsState $ getActorBody aid+    return $! PosSightLevels [(lid, p), (blid body, bpos body)]+      -- @PosFidAndSightLevels@ would be better, but no big deal+  SfxShun aid lid p _ -> do+    body <- getsState $ getActorBody aid+    return $! PosSightLevels [(lid, p), (blid body, bpos body)]+  SfxEffect _ aid _ _ _ -> singleAid aid  -- sometimes we don't see source, OK+  SfxItemApplied _ _ c -> singleContainerActor c+  SfxMsgFid fid _ -> return $! PosFid fid+  SfxRestart -> return PosAll+  SfxCollideTile aid _ -> singleAid aid+  SfxTaunt _ aid -> singleAid aid++-- | All items introduced by the atomic command, to be used in it.+iidUpdAtomic :: UpdAtomic -> [ItemId]+iidUpdAtomic cmd = case cmd of+  UpdRegisterItems{} -> []+  UpdCreateActor{} -> []  -- iids and items needed even on server+  UpdDestroyActor{} -> []+  UpdCreateItem{} -> []+  UpdDestroyItem{} -> []+  UpdSpotActor _ body -> getCarriedIidsAndTrunk body+  UpdLoseActor{} -> []  -- already seen, so items known+  UpdSpotItem _ iid _ _ -> [iid]+  UpdLoseItem{} -> []+  UpdSpotItemBag _ _ bag -> EM.keys bag+  UpdLoseItemBag{} -> []+  UpdMoveActor{} -> []+  UpdWaitActor{} -> []+  UpdDisplaceActor{} -> []+  UpdMoveItem{} -> []+  UpdRefillHP{} -> []+  UpdRefillCalm{} -> []+  UpdTrajectory{} -> []+  UpdQuitFaction{} -> []+  UpdSpotStashFaction{} -> []+  UpdLoseStashFaction{} -> []+  UpdLeadFaction{} -> []+  UpdDiplFaction{} -> []+  UpdDoctrineFaction{} -> []+  UpdAutoFaction{} -> []+  UpdRecordKill{} -> []+  UpdAlterTile{} -> []+  UpdAlterExplorable{} -> []+  UpdAlterGold{} -> []+  UpdSearchTile{} -> []+  UpdHideTile{} -> []+  UpdSpotTile{} -> []+  UpdLoseTile{} -> []+  UpdSpotEntry{} -> []+  UpdLoseEntry{} -> []+  UpdAlterSmell{} -> []+  UpdSpotSmell{} -> []+  UpdLoseSmell{} -> []+  UpdTimeItem iid _ _ _ -> [iid]+  UpdAgeGame{} -> []+  UpdUnAgeGame{} -> []+  UpdDiscover _ iid _ _ -> [iid]+  UpdCover _ iid _ _ -> [iid]+  UpdDiscoverKind{} -> []+  UpdCoverKind{} -> []+  UpdDiscoverAspect _ iid _ -> [iid]+  UpdCoverAspect _ iid _ -> [iid]+  UpdDiscoverServer{} -> []  -- never sent to clients+  UpdCoverServer{} -> []+  UpdPerception{} -> []+  UpdRestart{} -> []+  UpdRestartServer{} -> []+  UpdResume{} -> []+  UpdResumeServer{} -> []+  UpdKillExit{} -> []+  UpdWriteSave -> []+  UpdHearFid{} -> []+  UpdMuteMessages{} -> []++-- | All items introduced by the atomic special effect, to be used in it.+iidSfxAtomic :: SfxAtomic -> [ItemId]+iidSfxAtomic cmd = case cmd of+  SfxStrike _ _ iid -> [iid]+  SfxRecoil _ _ iid -> [iid]+  SfxSteal _ _ iid -> [iid]+  SfxRelease _ _ iid -> [iid]+  SfxProject _ iid -> [iid]+  SfxReceive _ iid -> [iid]+  SfxApply _ iid -> [iid]+  SfxCheck _ iid -> [iid]+  SfxTrigger{} -> []+  SfxShun{} -> []+  SfxEffect{} -> []+  SfxItemApplied _ iid _ -> [iid]+  SfxMsgFid{} -> []+  SfxRestart{} -> []+  SfxCollideTile{} -> []+  SfxTaunt{} -> []++pointsProjBody :: Actor -> [Point] -> PosAtomic+pointsProjBody body ps =+  if bproj body+  then PosSight (blid body) ps+  else PosFidAndSight (bfid body) (blid body) ps++posProjBody :: Actor -> PosAtomic+posProjBody body = pointsProjBody body [bpos body]++singleAid :: MonadStateRead m => ActorId -> m PosAtomic+singleAid aid = do+  body <- getsState $ getActorBody aid+  return $! posProjBody body++doubleAid :: MonadStateRead m => ActorId -> ActorId -> m PosAtomic+doubleAid source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  -- No @PosFidAndSight@ instead of @PosSight@, because both positions+  -- need to be seen to have the enemy actor in client's state.+  return $! assert (blid sb == blid tb) $ PosSight (blid sb) [bpos sb, bpos tb]++singleContainerStash :: MonadStateRead m => Container -> m PosAtomic+singleContainerStash (CFloor lid p) = return $! PosSight lid [p]+singleContainerStash (CEmbed lid p) = return $! PosSight lid [p]+singleContainerStash (CActor aid cstore) = do+  b <- getsState $ getActorBody aid+  mlidPos <- lidPosOfStash b cstore+  return $! maybe (posProjBody b)+                  (\lidPos -> PosSightLevels [lidPos, (blid b, bpos b)])+                    -- the actor's position is needed so that a message+                    -- about the actor is not sent to a client that doesn't+                    -- know the actor; actor's faction is ignored, because+                    -- for these operations actor doesn't vanish+                  mlidPos+singleContainerStash (CTrunk fid lid p) = return $! PosFidAndSight fid lid [p]++singleContainerActor :: MonadStateRead m => Container -> m PosAtomic+singleContainerActor (CFloor lid p) = return $! PosSight lid [p]+singleContainerActor (CEmbed lid p) = return $! PosSight lid [p]+singleContainerActor (CActor aid _) = do+  b <- getsState $ getActorBody aid+  return $! posProjBody b+    -- stash position is ignored, because for these operations, nothing+    -- is added to that position; the store name is only used for flavour text+singleContainerActor (CTrunk fid lid p) = return $! PosFidAndSight fid lid [p]++lidPosOfStash :: MonadStateRead m+              => Actor -> CStore -> m (Maybe (LevelId, Point))+lidPosOfStash b cstore =+  case cstore of+    CStash -> do+      mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+      case mstash of+        Just{} -> return mstash+        Nothing -> error $ "manipulating void stash" `showFailure` b+    _ -> return Nothing++-- | Decompose an atomic action that is outside a client's visiblity.+-- The decomposed actions give less information that the original command,+-- but some of them may fall within the visibility range of the client.+-- The original action may give more information than even the total sum+-- of all actions it's broken into. E.g., @UpdMoveActor@+-- informs about the continued existence of the actor between+-- moves vs popping out of existence and then back in.+--+-- This is computed in server's @State@ from before performing the command.+breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic]+breakUpdAtomic cmd = case cmd of+  UpdCreateItem verbose iid item kit (CActor aid CStash) -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) ->+        return [UpdCreateItem verbose iid item kit (CFloor lid pos)]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, item)+  UpdDestroyItem verbose iid item kit (CActor aid CStash) -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) ->+        return [UpdDestroyItem verbose iid item kit (CFloor lid pos)]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, item)+  UpdSpotItem verbose iid kit (CActor aid CStash) -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> return [UpdSpotItem verbose iid kit (CFloor lid pos)]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, iid)+  UpdLoseItem verbose iid kit (CActor aid CStash) -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> return [UpdLoseItem verbose iid kit (CFloor lid pos)]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, iid)+  UpdSpotItemBag verbose (CActor aid CStash) bag -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> return [UpdSpotItemBag verbose (CFloor lid pos) bag]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, bag)+  UpdLoseItemBag verbose (CActor aid CStash) bag -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> return [UpdLoseItemBag verbose (CFloor lid pos) bag]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, bag)+  UpdMoveItem iid k aid CStash store2 -> do+    b <- getsState $ getActorBody aid+    bag <- getsState $ getBodyStoreBag b CStash+    let (k1, it1) = bag EM.! iid+        kit = assert (k <= k1) (k, take k it1)+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> return [ UpdLoseItem True iid kit (CFloor lid pos)+                                , UpdSpotItem True iid kit (CActor aid store2) ]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, iid)+  UpdMoveItem iid k aid store1 CStash -> do+    b <- getsState $ getActorBody aid+    bag <- getsState $ getBodyStoreBag b store1+    let (k1, it1) = bag EM.! iid+        kit = assert (k <= k1) (k, take k it1)+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> return [ UpdLoseItem True iid kit (CActor aid store1)+                                , UpdSpotItem True iid kit (CFloor lid pos) ]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, iid)+  UpdMoveActor aid fromP toP -> do+    -- We assume other factions don't see leaders and we know the actor's+    -- faction always sees the atomic command and no other commands+    -- may be inserted between the two below, so the leader doesn't+    -- need to be updated, even when aid is the leader.+    b <- getsState $ getActorBody aid+    return [ UpdLoseActor aid b+           , UpdSpotActor aid b {bpos = toP, boldpos = Just fromP} ]+  UpdDisplaceActor source target -> do+    sb <- getsState $ getActorBody source+    tb <- getsState $ getActorBody target+    -- The order ensures the invariant that no two big actors occupy the same+    -- position is maintained. The actions about leadership are required+    -- to keep faction data (identify of the leader) consistent with actor+    -- data (the actor that is the leader exists). Here, for speed+    -- and simplicity we violate the property that in a faction+    -- that has leaders, if any eligible actor is alive,+    -- the leader is set, because for a moment there may be no leader,+    -- even though other actors of the faction may exist.+    msleader <- getsState $ gleader . (EM.! bfid sb) . sfactionD+    mtleader <- getsState $ gleader . (EM.! bfid tb) . sfactionD+    return $ [ UpdLeadFaction (bfid sb) msleader Nothing+             | Just source == msleader ]+             ++ [ UpdLeadFaction (bfid tb) mtleader Nothing+                | Just target == mtleader ]+             ++ [ UpdLoseActor source sb+                , UpdLoseActor target tb+                , UpdSpotActor source sb { bpos = bpos tb+                                         , boldpos = Just $ bpos sb }+                , UpdSpotActor target tb { bpos = bpos sb+                                         , boldpos = Just $ bpos tb } ]+             ++ [ UpdLeadFaction (bfid sb) Nothing msleader+                | Just source == msleader ]+             ++ [ UpdLeadFaction (bfid tb) Nothing mtleader+                | Just target == mtleader ]+  UpdTimeItem iid (CActor aid CStash) fromIt toIt -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> return [UpdTimeItem iid (CFloor lid pos) fromIt toIt]+      Nothing -> error $ "manipulating void stash" `showFailure` (aid, b, iid)+  _ -> return []++-- | What is the main map level the @PosAtomic@ refers to, if any.+lidOfPos :: PosAtomic -> Maybe LevelId+lidOfPos posAtomic =+  case posAtomic of+    PosSight lid _ -> Just lid+    PosFidAndSight _ lid _ -> Just lid+    PosSmell lid _ -> Just lid+    PosSightLevels [] -> Nothing+    PosSightLevels ((lid, _) : _) -> Just lid+    PosFid{} -> Nothing+    PosFidAndSer{} -> Nothing+    PosSer -> Nothing+    PosAll -> Nothing+    PosNone -> Nothing++-- | Given the client, its perception and an atomic command, determine+-- if the client notices the command.+seenAtomicCli :: Bool -> FactionId -> PerLid -> PosAtomic -> Bool+seenAtomicCli knowEvents fid perLid posAtomic =+  let per = (perLid EM.!)+  in case posAtomic of+    PosSight lid ps -> all (`ES.member` totalVisible (per lid)) ps || knowEvents+    PosFidAndSight fid2 lid ps ->+      fid == fid2 || all (`ES.member` totalVisible (per lid)) ps || knowEvents+    PosSmell lid ps -> all (`ES.member` totalSmelled (per lid)) ps || knowEvents+    PosSightLevels l ->+      let visible (lid, pos) = pos `ES.member` totalVisible (per lid)+      in all visible l || knowEvents+    PosFid fid2 -> fid == fid2+    PosFidAndSer fid2 -> fid == fid2+    PosSer -> False+    PosAll -> True+    PosNone -> False++-- | Determine whether the server would see a command that has+-- the given visibilty conditions.+seenAtomicSer :: PosAtomic -> Bool+seenAtomicSer posAtomic =+  case posAtomic of+    PosFid _ -> False+    PosNone -> error $ "no position possible" `showFailure` posAtomic+    _ -> True
+ engine-src/Game/LambdaHack/Client.hs view
@@ -0,0 +1,25 @@+-- | Semantics of responses that are sent from server to clients,+-- in terms of client state transformations,+-- and semantics of human commands and AI moves, in terms of requests+-- to be sent from the client to the server.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Client+  ( -- * Re-exported from "Game.LambdaHack.Client.LoopM"+    loopCli+    -- * Re-exported from "Game.LambdaHack.Client.Request"+  , RequestAI, ReqAI(..), RequestUI, ReqUI(..), RequestTimed(..)+    -- * Re-exported from "Game.LambdaHack.Client.Response"+  , Response (..)+    -- * Re-exported from "Game.LambdaHack.Client.UI"+  , CCUI+  , UIOptions, applyUIOptions, uOverrideCmdline, mkUIOptions+  ) where++import Prelude ()++import Game.LambdaHack.Client.LoopM+import Game.LambdaHack.Client.Request+import Game.LambdaHack.Client.Response+import Game.LambdaHack.Client.UI
+ engine-src/Game/LambdaHack/Client/AI.hs view
@@ -0,0 +1,88 @@+-- | Ways for the client to use AI to produce server requests, based on+-- the client's view of the game state.+module Game.LambdaHack.Client.AI+  ( queryAI+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , pickActorAndAction+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Client.AI.PickActionM+import Game.LambdaHack.Client.AI.PickActorM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.Request+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Types++-- | Handle the move of an actor under AI control (regardless if the whole+-- faction is under human or computer control).+queryAI :: MonadClient m => ActorId -> m RequestAI+queryAI aid = do+  -- @sleader@ may be different from @gleader@ due to @restoreLeaderFromRun@,+  -- but only leaders may change faction leader, so we fix that beforehand:+  body <- getsState $ getActorBody aid+  foeAssocs <- getsState $ foeRegularAssocs (bfid body) (blid body)+  friendAssocs <- getsState $ friendRegularAssocs (bfid body) (blid body)+  mleader <- getsState $ gleader . (EM.! bfid body) . sfactionD+  mleaderCli <- getsClient sleader+  unless (Just aid == mleader || mleader == mleaderCli) $+    -- @aid@ is not the leader, so he can't change leader later on,+    -- so we match the leaders here+    modifyClient $ \cli -> cli {_sleader = mleader}+  (aidToMove, treq, oldFlee) <- pickActorAndAction foeAssocs friendAssocs+                                                   Nothing aid+  let tryAgain = do+        -- Leader waits; a waste; try once to pick a yet different leader+        -- or at least a non-waiting action. Undo state changes in @pickAction@:+        modifyClient $ \cli -> cli+          { _sleader = mleader+          , sfleeD = EM.alter (const oldFlee) aidToMove $ sfleeD cli }+        (a, t, _) <- pickActorAndAction foeAssocs friendAssocs+                                        (Just aidToMove) aid+        return (a, t)+  (aidToMove2, treq2) <-+    if mleader /= Just aid+    then return (aidToMove, treq)+    else case treq of+      ReqWait -> tryAgain+      ReqYell -> tryAgain+      _ -> return (aidToMove, treq)+  return ( ReqAITimed treq2+         , if aidToMove2 /= aid then Just aidToMove2 else Nothing )++-- | Pick an actor to move and an action for him to perform, given an optional+-- previous candidate actor and action and the server-proposed actor.+pickActorAndAction :: MonadClient m+                   => [(ActorId, Actor)] -> [(ActorId, Actor)]+                   -> Maybe ActorId -> ActorId+                   -> m (ActorId, RequestTimed, Maybe (Point, Time))+pickActorAndAction foeAssocs friendAssocs maid aid = do+  mleader <- getsClient sleader+  aidToMove <-+    if mleader == Just aid+    then pickActorToMove foeAssocs friendAssocs maid+    else do+      setTargetFromDoctrines foeAssocs friendAssocs aid+      return aid+  oldFlee <- getsClient $ EM.lookup aidToMove . sfleeD+  -- Trying harder (@retry@) whenever no better leader found and so at least+  -- a non-waiting action should be found.+  -- If a new leader found, there is hope (but we don't check)+  -- that he gets a non-waiting action without any desperate measures.+  let retry = Just aidToMove == maid+  treq <- pickAction foeAssocs friendAssocs aidToMove retry+  return (aidToMove, treq, oldFlee)
+ engine-src/Game/LambdaHack/Client/AI/ConditionM.hs view
@@ -0,0 +1,433 @@+-- | Assorted conditions used later on in AI logic.+module Game.LambdaHack.Client.AI.ConditionM+  ( condAimEnemyTargetedM+  , condAimEnemyOrStashM+  , condAimEnemyOrRememberedM+  , condAimNonEnemyPresentM+  , condAimCrucialM+  , condTgtNonmovingEnemyM+  , condAdjTriggerableM+  , meleeThreatDistList+  , condBlocksFriendsM+  , condFloorWeaponM+  , condNoEqpWeaponM+  , condCanProjectM+  , condProjectListM+  , benAvailableItems+  , hinders+  , condDesirableFloorItemM+  , benGroundItems+  , desirableItem+  , condSupport+  , condAloneM+  , condShineWouldBetrayM+  , fleeList+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM++import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.RuleKind as RK+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- All conditions are (partially) lazy, because they are not always+-- used in the strict monadic computations they are in.++-- | Require that a target enemy is visible by the party.+condAimEnemyTargetedM :: MonadClientRead m => ActorId -> m Bool+condAimEnemyTargetedM aid = do+  btarget <- getsClient $ getTarget aid+  return $ case btarget of+    Just (TEnemy _) -> True+    _ -> False++-- | Require that a target enemy or enemy stash is visible by the party.+condAimEnemyOrStashM :: MonadClientRead m => ActorId -> m Bool+condAimEnemyOrStashM aid = do+  btarget <- getsClient $ getTarget aid+  return $ case btarget of+    Just (TEnemy _) -> True+    Just (TPoint (TStash _) _ _) -> True  -- speedup from: lid == blid b+    _ -> False++-- | Require that a target enemy is remembered on the actor's level.+condAimEnemyOrRememberedM :: MonadClientRead m => ActorId -> m Bool+condAimEnemyOrRememberedM aid = do+  b <- getsState $ getActorBody aid+  btarget <- getsClient $ getTarget aid+  return $ case btarget of+    Just (TEnemy _) -> True+    Just (TPoint (TEnemyPos _) lid _) -> lid == blid b+    Just (TPoint (TStash _) lid _) -> lid == blid b+    _ -> False++-- | Require that a target non-enemy is visible by the party.+condAimNonEnemyPresentM :: MonadClientRead m => ActorId -> m Bool+condAimNonEnemyPresentM aid = do+  btarget <- getsClient $ getTarget aid+  return $ case btarget of+    Just (TNonEnemy _) -> True+    _ -> False++-- | Require that the target is crucial to success, e.g., an item,+-- or that it's not too far away and so the changes to get it are high.+condAimCrucialM :: MonadClientRead m => ActorId -> m Bool+condAimCrucialM aid = do+  b <- getsState $ getActorBody aid+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  return $ case mtgtMPath of+    Just TgtAndPath{tapTgt=TEnemy _} -> True+    Just TgtAndPath{tapTgt=TPoint tgoal lid _, tapPath=Just AndPath{pathLen}} ->+      lid == blid b+      && (pathLen < 10  -- close enough to get there first+          || tgoal `notElem` [TUnknown, TKnown])+    Just TgtAndPath{tapTgt=TVector{}, tapPath=Just AndPath{pathLen}} ->+      pathLen < 7  -- can't say if the target important, but the constants+                   -- from @take6@ and @traSlack7@ ensure target is+                   -- already approached or close to level edge+                   -- or not a random @traSlack7@ wandering+    _ -> False  -- includes the case of target with no path++-- | Check if the target is a nonmoving enemy.+condTgtNonmovingEnemyM :: MonadClientRead m => ActorId -> m Bool+condTgtNonmovingEnemyM aid = do+  btarget <- getsClient $ getTarget aid+  case btarget of+    Just (TEnemy enemy) -> do+      actorMaxSk <- getsState $ getActorMaxSkills enemy+      return $ Ability.getSk Ability.SkMove actorMaxSk <= 0+    _ -> return False++-- | Require the actor stands on or adjacent to a triggerable tile+-- (e.g., stairs).+condAdjTriggerableM :: MonadStateRead m => Ability.Skills -> ActorId -> m Bool+condAdjTriggerableM actorSk aid = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let alterSkill = Ability.getSk Ability.SkAlter actorSk+      alterMinSkill p = Tile.alterMinSkill coTileSpeedup $ lvl `at` p+      underFeet p = p == bpos b  -- if enter and alter, be more permissive+      -- Before items are applied (which AI attempts even if apply+      -- skills too low), tile must be alerable, hence both checks.+      hasTriggerable p = (underFeet p+                          || alterSkill >= fromEnum (alterMinSkill p))+                         && p `EM.member` lembed lvl+  return $ any hasTriggerable $ bpos b : vicinityUnsafe (bpos b)++-- | Produce the chess-distance-sorted list of non-low-HP,+-- melee-cabable foes on the level. We don't consider path-distance,+-- because we are interested in how soon the foe can close in to hit us,+-- which can diverge greately from path distance for short distances,+-- e.g., when terrain gets revealed. We don't consider non-moving actors,+-- because they can't chase us and also because they can't be aggresive+-- so to resolve the stalemate, the opposing AI has to be aggresive+-- by ignoring them and closing in to melee distance.+meleeThreatDistList :: [(ActorId, Actor)] -> ActorId -> State+                    -> [(Int, (ActorId, Actor))]+meleeThreatDistList foeAssocs aid s =+  let actorMaxSkills = sactorMaxSkills s+      b = getActorBody aid s++      strongActor (aid2, b2) =+        let actorMaxSk = actorMaxSkills EM.! aid2+            nonmoving = Ability.getSk Ability.SkMove actorMaxSk <= 0+        in not (hpTooLow b2 actorMaxSk || nonmoving)+           && actorCanMeleeToHarm actorMaxSkills aid2 b2+      allThreats = filter strongActor foeAssocs+      addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2))+  in sortBy (comparing fst) $ map addDist allThreats++-- | Require the actor blocks the paths of any of his party members.+condBlocksFriendsM :: MonadClientRead m => ActorId -> m Bool+condBlocksFriendsM aid = do+  b <- getsState $ getActorBody aid+  targetD <- getsClient stargetD+  let blocked aid2 = aid2 /= aid &&+        case EM.lookup aid2 targetD of+          Just TgtAndPath{tapPath=Just AndPath{pathList=q : _}} | q == bpos b ->+            True+          _ -> False+  any blocked <$> getsState (fidActorRegularIds (bfid b) (blid b))++-- | Require the actor stands over a weapon that would be auto-equipped,+-- if only it was a desirable item (checked elsewhere).+condFloorWeaponM :: MonadStateRead m => ActorId -> m Bool+condFloorWeaponM aid =+  any (IA.checkFlag Ability.Meleeable . aspectRecordFull . snd) <$>+    getsState (fullAssocs aid [CGround])++-- | Check whether the actor has no weapon in equipment.+condNoEqpWeaponM :: MonadStateRead m => ActorId -> m Bool+condNoEqpWeaponM aid =+  not . any (IA.checkFlag Ability.Meleeable . aspectRecordFull . snd) <$>+    getsState (fullAssocs aid [CEqp])++-- | Require that the actor can project any items.+condCanProjectM :: MonadClientRead m => Int -> ActorId -> m Bool+condCanProjectM skill aid = do+  side <- getsClient sside+  curChal <- getsClient scurChal+  fact <- getsState $ (EM.! side) . sfactionD+  if skill < 1+     || ckeeper curChal && fhasUI (gkind fact)+  then return False+  else  -- shortcut+    -- Compared to conditions in @projectItem@, range and charge are ignored,+    -- because they may change by the time the position for the fling+    -- is reached.+    not . null <$> condProjectListM skill aid++condProjectListM :: MonadClientRead m+                 => Int -> ActorId+                 -> m [(Double, CStore, ItemId, ItemFull, ItemQuant)]+condProjectListM skill aid = do+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyOrRemembered <- condAimEnemyOrRememberedM aid+  discoBenefit <- getsClient sdiscoBenefit+  getsState $ projectList discoBenefit skill aid+                          condShineWouldBetray condAimEnemyOrRemembered++projectList :: DiscoveryBenefit -> Int -> ActorId -> Bool -> Bool -> State+            -> [(Double, CStore, ItemId, ItemFull, ItemQuant)]+projectList discoBenefit skill aid+            condShineWouldBetray condAimEnemyOrRemembered s =+  let b = getActorBody aid s+      actorMaxSk = getActorMaxSkills aid s+      calmE = calmEnough b actorMaxSk+      heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltasSerious (bcalmDelta b)+      uneasy = condAimEnemyOrRemembered+               || not calmE+               || heavilyDistressed+        -- don't take recent fleeing into account when item can be lost+      coeff CGround = 2  -- pickup turn saved+      coeff COrgan = error $ "" `showFailure` benList+      coeff CEqp = 1000  -- must hinder currently (or be very potent);+                         -- note: not larger, to avoid Int32 overflow+      coeff CStash = 1+      -- This detects if the value of keeping the item in eqp is in fact < 0.+      hind = hinders condShineWouldBetray uneasy actorMaxSk+      goodMissile (Benefit{benInEqp, benFling}, cstore, iid, itemFull, kit) =+        let arItem = aspectRecordFull itemFull+            benR = coeff cstore * benFling+        in if benR < -1  -- ignore very weak projectiles+              && (not benInEqp  -- can't wear, so OK to risk losing or breaking+                  || not (IA.checkFlag Ability.Meleeable arItem)+                       -- anything else expendable+                     && hind itemFull)  -- hinders now, so possibly often+              && permittedProjectAI skill calmE itemFull+           then Just (benR, cstore, iid, itemFull, kit)+           else Nothing+      stores = [CStash, CGround] ++ [CEqp | calmE]+      benList = benAvailableItems discoBenefit aid stores s+  in mapMaybe goodMissile benList++-- | Produce the list of items from the given stores available to the actor+-- and the items' values.+benAvailableItems :: DiscoveryBenefit -> ActorId -> [CStore] -> State+                  -> [(Benefit, CStore, ItemId, ItemFull, ItemQuant)]+benAvailableItems discoBenefit aid cstores s =+  let b = getActorBody aid s+      mstash = gstash $ sfactionD s EM.! bfid b+      ben _ CGround | mstash == Just (blid b, bpos b) = []+      ben bag cstore =+        [ (discoBenefit EM.! iid, cstore, iid, itemToFull iid s, kit)+        | (iid, kit) <- EM.assocs bag]+      benCStore cs = ben (getBodyStoreBag b cs s) cs+  in concatMap benCStore cstores++hinders :: Bool -> Bool -> Ability.Skills -> ItemFull -> Bool+hinders condShineWouldBetray uneasy actorMaxSk itemFull =+  let arItem = aspectRecordFull itemFull+      itemShine = 0 < IA.getSkill Ability.SkShine arItem+      -- @condAnyFoeAdj@ is not checked, because it's transient and also item+      -- management is unlikely to happen during melee, anyway+      itemShineBad = condShineWouldBetray && itemShine+  in -- In the presence of enemies (seen, remembered or unseen but distressing)+     -- actors want to hide in the dark.+     uneasy && itemShineBad  -- even if it's a weapon, take it off+     -- Fast actors want to hit hard, because they hit much more often+     -- than receive hits.+     || gearSpeed actorMaxSk > speedWalk+        && not (IA.checkFlag Ability.Meleeable arItem)+             -- in case it's the only weapon+        && 0 > IA.getSkill Ability.SkHurtMelee arItem++-- | Require that the actor stands over a desirable item.+condDesirableFloorItemM :: MonadClientRead m => ActorId -> m Bool+condDesirableFloorItemM aid = not . null <$> benGroundItems aid++-- | Produce the list of items on the ground beneath the actor+-- that are worth picking up.+benGroundItems :: MonadClientRead m+               => ActorId+               -> m [(Benefit, CStore, ItemId, ItemFull, ItemQuant)]+benGroundItems aid = do+  cops <- getsState scops+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  discoBenefit <- getsClient sdiscoBenefit+  let canEsc = fcanEscape (gkind fact)+      isDesirable (ben, _, _, itemFull, _) =+        desirableItem cops canEsc (benPickup ben)+                      (aspectRecordFull itemFull) (itemKind itemFull)+                      99  -- fake, because no time is wasted walking to item+  filter isDesirable+    <$> getsState (benAvailableItems discoBenefit aid [CGround])++desirableItem :: COps -> Bool -> Double -> IA.AspectRecord -> IK.ItemKind -> Int+              -> Bool+desirableItem COps{corule}+              canEsc benPickup arItem itemKind k =+  let loneProjectile =+        IK.isymbol itemKind == IK.rsymbolProjectile (RK.ritemSymbols corule)+        && k == 1+        && Dice.infDice (IK.icount itemKind) > 1+             -- never generated as lone; usually means weak+      useful = if canEsc+               then benPickup > 0+                    || IA.checkFlag Ability.Precious arItem+               else -- A hack to prevent monsters from picking up+                    -- treasure meant for heroes.+                 let preciousNotUseful = IA.isHumanTrinket itemKind+                 in benPickup > 0 && not preciousNotUseful+  in useful && not loneProjectile++condSupport :: MonadClientRead m+            => [(ActorId, Actor)] -> Int -> ActorId -> m Bool+{-# INLINE condSupport #-}+condSupport friendAssocs param aid = do+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  getsState $ strongSupport friendAssocs param aid mtgtMPath++strongSupport :: [(ActorId, Actor)]+              -> Int -> ActorId -> Maybe TgtAndPath -> State+              -> Bool+strongSupport friendAssocs param aid mtgtMPath s =+  -- The smaller the area scanned for friends, the lower number required.+  let actorMaxSkills = sactorMaxSkills s+      actorMaxSk = actorMaxSkills EM.! aid+      n = min 2 param - Ability.getSk Ability.SkAggression actorMaxSk+      b = getActorBody aid s+      approaching b2 = case mtgtMPath of+        Just TgtAndPath{tapTgt=TEnemy{},tapPath=Just AndPath{pathGoal}} ->+            chessDist (bpos b2) pathGoal <= 1 + param  -- will soon melee anyway+        _ -> False+      closeEnough b2 = let dist = chessDist (bpos b) (bpos b2)+                       in dist > 0 && (dist <= max 2 param || approaching b2)+      closeAndStrong (aid2, b2) = closeEnough b2+                                  && actorCanMeleeToHarm actorMaxSkills aid2 b2+      closeAndStrongFriends = filter closeAndStrong friendAssocs+  in n <= 0 || not (null (drop (n - 1) closeAndStrongFriends))+       -- optimized: length closeAndStrongFriends >= n++-- The numbers reflect fleeing AI conditions for non-aggresive actors+-- so that actors don't wait for support that is not possible due to not+-- enough friends on the level, even counting sleeping ones.+condAloneM :: MonadStateRead m => [(ActorId, Actor)] -> ActorId -> m Bool+condAloneM friendAssocs aid = do+  b <- getsState $ getActorBody aid+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+  let onStashLevel = case mstash of+        Nothing -> False+        Just (lid, _) -> lid == blid b+  return $! length friendAssocs <= if onStashLevel then 3 else 2++-- | Require that the actor stands in the dark and so would be betrayed+-- by his own equipped light,+condShineWouldBetrayM :: MonadStateRead m => ActorId -> m Bool+condShineWouldBetrayM aid = do+  b <- getsState $ getActorBody aid+  aInAmbient <- getsState $ actorInAmbient b+  return $ not aInAmbient  -- tile is dark, so actor could hide++-- | Produce a list of acceptable adjacent points to flee to.+fleeList :: MonadClientRead m+         => [(ActorId, Actor)] -> ActorId -> m ([(Int, Point)], [(Int, Point)])+fleeList foeAssocs aid = do+  COps{coTileSpeedup} <- getsState scops+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  -- Prefer fleeing along the path to target, unless the target is a foe,+  -- in which case flee in the opposite direction.+  let etgtPath = case mtgtMPath of+        Just TgtAndPath{ tapPath=Just AndPath{pathList, pathGoal}+                       , tapTgt } -> case tapTgt of+          TEnemy{} -> Left pathGoal+          TPoint TEnemyPos{} _ _ -> Left pathGoal+            -- this is too weak, because only one is recorded and sometimes+            -- many are needed to decide to flee next turn as well+          _ -> Right pathList+        _ -> Right []+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  localTime <- getsState $ getLocalTime (blid b)+  fleeD <- getsClient sfleeD+  -- But if fled recently, prefer even more fleeing further this turn.+  let eOldFleeOrTgt = case EM.lookup aid fleeD of+        Just (fleeStart, time) | timeRecent5 localTime time -> Left fleeStart+        _ -> etgtPath+      myVic = vicinityUnsafe $ bpos b+      dist p | null foeAssocs = 100+             | otherwise = minimum $ map (chessDist p . bpos . snd) foeAssocs+      dVic = map (dist &&& id) myVic+      -- Flee, if possible. Direct access required; not enough time to open.+      -- Can't be occupied.+      accWalkUnocc p = Tile.isWalkable coTileSpeedup (lvl `at` p)+                       && not (occupiedBigLvl p lvl)+                       && not (occupiedProjLvl p lvl)+      accWalkVic = filter (accWalkUnocc . snd) dVic+      gtVic = filter ((> dist (bpos b)) . fst) accWalkVic+      eqVicRaw = filter ((== dist (bpos b)) . fst) accWalkVic+      (eqVicOld, eqVic) = partition ((== boldpos b) . Just . snd) eqVicRaw+      accNonWalkUnocc p = not (Tile.isWalkable coTileSpeedup (lvl `at` p))+                          && Tile.isEasyOpen coTileSpeedup (lvl `at` p)+                          && not (occupiedBigLvl p lvl)+                          && not (occupiedProjLvl p lvl)+      accNonWalkVic = filter (accNonWalkUnocc . snd) dVic+      gtEqNonVic = filter ((>= dist (bpos b)) . fst) accNonWalkVic+      ltAllVic = filter ((< dist (bpos b)) . fst) dVic+      rewardPath mult (d, p) = case eOldFleeOrTgt of+        Right tgtPathList | p `elem` tgtPathList ->+          (100 * mult * d, p)+        Right tgtPathList | any (adjacent p) tgtPathList ->+          (10 * mult * d, p)+        Left pathGoal | bpos b /= pathGoal ->+          let venemy = towards (bpos b) pathGoal+              vflee = towards (bpos b) p+              sq = euclidDistSqVector venemy vflee+              skew = case compare sq 2 of+                GT -> 100 * sq+                EQ -> 10 * sq+                LT -> sq  -- going towards enemy (but may escape adjacent foes)+          in (mult * skew * d, p)+        _ -> (mult * d, p)  -- far from target path or even on target goal+      goodVic = map (rewardPath 10000) gtVic+                ++ map (rewardPath 100) eqVic+      badVic = map (rewardPath 1) $ gtEqNonVic ++ eqVicOld ++ ltAllVic+  return (goodVic, badVic)
+ engine-src/Game/LambdaHack/Client/AI/PickActionM.hs view
@@ -0,0 +1,1308 @@+-- | AI procedure for picking the best action for an actor.+module Game.LambdaHack.Client.AI.PickActionM+  ( pickAction+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , actionStrategy, waitBlockNow, yellNow+  , pickup, equipItems, yieldUnneeded, unEquipItems+  , groupByEqpSlot, bestByEqpSlot, harmful, meleeBlocker, meleeAny+  , trigger, projectItem, ApplyItemGroup, applyItem, flee+  , displaceFoe, displaceBlocker, displaceTgt+  , chase, moveTowards, moveOrRunAid+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Either+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Function+import           Data.Ratio++import           Game.LambdaHack.Client.AI.ConditionM+import           Game.LambdaHack.Client.AI.Strategy+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.Ability+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal++-- | Pick the most desirable AI ation for the actor.+pickAction :: MonadClient m+           => [(ActorId, Actor)] -> [(ActorId, Actor)] -> ActorId -> Bool+           -> m RequestTimed+pickAction foeAssocs friendAssocs aid retry = do+  side <- getsClient sside+  body <- getsState $ getActorBody aid+  let !_A = assert (bfid body == side+                    `blame` "AI tries to move enemy actor"+                    `swith` (aid, bfid body, side)) ()+  let !_A = assert (not (bproj body)+                    `blame` "AI gets to manually move its projectiles"+                    `swith` (aid, bfid body, side)) ()+  stratAction <- actionStrategy foeAssocs friendAssocs (blid body) aid retry+  let bestAction = bestVariant stratAction+      !_A = assert (not (nullFreq bestAction)  -- equiv to nullStrategy+                    `blame` "no AI action for actor"+                    `swith` (stratAction, aid, body)) ()+  -- Run the AI: chose an action from those given by the AI strategy.+  rndToAction $ frequency bestAction++-- AI strategy based on actor's sight, smell, etc.+-- Never empty.+actionStrategy :: MonadClient m+               => [(ActorId, Actor)] -> [(ActorId, Actor)]+               -> LevelId -> ActorId -> Bool+               -> m (Strategy RequestTimed)+actionStrategy foeAssocs friendAssocs lid aid retry = do+  condInMelee <- condInMeleeM lid+  randomAggressionThreshold <- rndToAction $ randomR0 10+  actionStrategyRead condInMelee foeAssocs friendAssocs+                     randomAggressionThreshold lid aid retry++-- This is close to being in @MonadClientRead@, but not quite, due to+-- random numbers used explicitly in a couple of places (e.g., weapon choice),+-- which should be fixed and expressed via @Strategy@ instead,+-- and due to recoding the fleeing preference, which should be+-- factored out and done in the @actionStrategy@ wrapper.+--+-- After the AI code is totally rewritten soon, this should be revisited.+actionStrategyRead :: forall m. MonadClient m+                   => Bool+                   -> [(ActorId, Actor)] -> [(ActorId, Actor)]+                   -> Int -> LevelId -> ActorId -> Bool+                   -> m (Strategy RequestTimed)+actionStrategyRead condInMelee foeAssocs friendAssocs+                   randomAggressionThreshold lid aid retry = do+  COps{coTileSpeedup} <- getsState scops+  mleader <- getsClient sleader+  body <- getsState $ getActorBody aid+  let !_A = assert (blid body == lid) ()+  lvl <- getLevel lid+  localTime <- getsState $ getLocalTime lid+  condAimEnemyTargeted <- condAimEnemyTargetedM aid+  condAimEnemyOrStash <- condAimEnemyOrStashM aid+  condAimEnemyOrRemembered <- condAimEnemyOrRememberedM aid+  condAimNonEnemyPresent <- condAimNonEnemyPresentM aid+  condAimCrucial <- condAimCrucialM aid+  actorMaxSkills <- getsState sactorMaxSkills+  condAnyFoeAdj <- getsState $ anyFoeAdj aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  condOurAdj <- getsState $ any (\(_, b) -> isFriend (bfid body) fact (bfid b))+                            . adjacentBigAssocs body+  oursExploring <- getsState $ oursExploringAssocs (bfid body)+  condAnyHarmfulFoeAdj <- getsState $ anyHarmfulFoeAdj actorMaxSkills aid+  threatDistL <- getsState $ meleeThreatDistList foeAssocs aid+  (fleeL, badVic) <- fleeList foeAssocs aid+  oldFleeD <- getsClient sfleeD+  condSupport1 <- condSupport friendAssocs 1 aid+  condSupport3 <- condSupport friendAssocs 3 aid+  condSolo <- condAloneM friendAssocs aid  -- solo fighters aggresive+  actorSk <- currentSkillsClient aid+  condCanProject <- condCanProjectM (getSk SkProject actorSk) aid+  condAdjTriggerable <- condAdjTriggerableM actorSk aid+  condBlocksFriends <- condBlocksFriendsM aid+  condNoEqpWeapon <- condNoEqpWeaponM aid+  condEnoughGear <- condEnoughGearM aid+  condFloorWeapon <- condFloorWeaponM aid+  condDesirableFloorItem <- condDesirableFloorItemM aid+  condTgtNonmovingEnemy <- condTgtNonmovingEnemyM aid+  explored <- getsClient sexplored+  -- This doesn't treat actors guarding stash specially, so on such levels+  -- man sleeping actors may reside for a long time. Variety, OK.+  let awakeAndNotGuarding (_, b) =+        bpos b /= bpos body+        && bwatch b /= WSleep+        && Just (lid, bpos b) /= gstash fact+      anyFriendOnLevelAwake = any awakeAndNotGuarding friendAssocs+      actorMaxSk = actorMaxSkills EM.! aid+      recentlyFled = maybe False (\(_, time) -> timeRecent5 localTime time)+                           (aid `EM.lookup` oldFleeD)+      prefersSleepWhenAwake = case bwatch body of+        WSleep -> Ability.getSk Ability.SkMoveItem actorMaxSk <= -10+        _ -> prefersSleep actorMaxSk  -- nm @WWake@+      mayFallAsleep = not condAimEnemyOrRemembered+                      && calmFull body actorMaxSk  -- only when fully relaxed+                      && mayContinueSleep+                      && canSleep actorSk+      mayContinueSleep = not condAimEnemyOrStash+                         && not (hpFull body actorSk)+                         && not uneasy+                         && not condAnyFoeAdj+                         && (anyFriendOnLevelAwake  -- friend guards the sleeper+                             || prefersSleepWhenAwake)  -- or he doesn't care+      dozes = case bwatch body of+                WWait n -> n > 0+                _ -> False+              && mayFallAsleep+              && Just aid /= mleader  -- best teammate for a task so stop dozing+      lidExplored = ES.member lid explored+      panicFleeL = fleeL ++ badVic+      condHpTooLow = hpTooLow body actorMaxSk+      heavilyDistressed =  -- actor hit by a proj or similarly distressed+        deltasSerious (bcalmDelta body)+      heavilyDistressedThisTurn =  -- if far from melee, almost sure hit by proj+        deltasSeriousThisTurn (bcalmDelta body)+      condNotCalmEnough = not (calmEnough body actorMaxSk)+      uneasy = heavilyDistressed || condNotCalmEnough || recentlyFled+      speed = gearSpeed actorMaxSk+      speed1_5 = speedScale (3%2) speed+      -- Max skills used, because we need to know if can melee as leader.+      condCanMelee = actorCanMelee actorMaxSkills aid body+      condMeleeBad = not ((condSolo || condSupport1) && condCanMelee)+      -- These are only melee threats.+      condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL+      threatAdj = takeWhile ((== 1) . fst) threatDistL+      condManyThreatsAdj = length threatAdj >= 2+      condFastThreatAdj =+        any (\(_, (aid2, _)) ->+              let ar2 = actorMaxSkills EM.! aid2+              in gearSpeed ar2 > speed1_5)+            threatAdj+      condNonStealthyThreatAdj =+        any (\(_, (aid2, b2)) ->+              let ar2 = actorMaxSkills EM.! aid2+              in Ability.getSk Ability.SkShine ar2 > 0+                 || isLit (bpos b2))+            threatAdj+      actorShines = Ability.getSk Ability.SkShine actorMaxSk > 0+      isLit pos = Tile.isLit coTileSpeedup (lvl `at` pos)+        -- solid tiles ignored, because not obvious if dark after removed+      canFleeIntoDark = not $ actorShines || all (isLit . snd) fleeL+      avoidAmbient = not condInMelee && uneasy && not actorShines+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  let condGoalIsLit = case mtgtMPath of+        Just TgtAndPath{tapPath=Just AndPath{pathGoal}} -> isLit pathGoal+        _ -> False+      -- Fleeing makes sense, because either actor can't melee,+      -- or at least won't flee without scoring a hit and return next turn,+      -- due to threat no longer seen (due to blindness or dark).+      fleeingMakesSense =+        not condCanMelee+        || (Ability.getSk Ability.SkSight actorMaxSk > 2+            || Ability.getSk Ability.SkNocto actorMaxSk > 2)+           && (Ability.getSk Ability.SkShine actorMaxSk > 2+               || condNonStealthyThreatAdj || null threatAdj)+      abInSkill sk = getSk sk actorSk > 0+      abInMaxSkill sk = getSk sk actorMaxSk > 0+      runSkills = [SkMove, SkDisplace]  -- not @SkAlter@, to ground sleepers+      stratToFreq :: Int+                  -> m (Strategy RequestTimed)+                  -> m (Frequency RequestTimed)+      stratToFreq scale mstrat = do+        st <- mstrat+        return $! if scale == 0+                  then mzero+                  else scaleFreq scale $ bestVariant st+      -- Order matters within the list, because it's summed with .| after+      -- filtering. Also, the results of prefix, distant and suffix+      -- are summed with .| at the end.+      prefix, suffix:: [([Skill], m (Strategy RequestTimed), Bool)]+      prefix =+        [ ( [SkApply]+          , applyItem actorSk aid ApplyFirstAid+          , not condAnyHarmfulFoeAdj && condHpTooLow)+        , ( [SkAlter]+          , trigger aid ViaStairs+              -- explore next or flee via stairs, even if to wrong level;+              -- in the latter case, may return via different stairs later on+          , condAdjTriggerable && not condAimEnemyOrStash+            && ((condNotCalmEnough || condHpTooLow)  -- flee+                && condMeleeBad && condAnyHarmfulFoeAdj+                || (lidExplored || condEnoughGear)  -- explore+                   && not condDesirableFloorItem) )+        , ( [SkDisplace]+          , displaceFoe aid  -- only swap with an enemy to expose him+                             -- and only if a friend is blocked by us+          , condAnyFoeAdj && condBlocksFriends)  -- later checks foe eligible+        , ( [SkMoveItem]+          , pickup aid True+          , condNoEqpWeapon  -- we assume organ weapons usually inferior+            && condDesirableFloorItem && condFloorWeapon && not condHpTooLow+            && abInMaxSkill SkMelee )+        , ( [SkAlter]+          , trigger aid ViaEscape+          , condAdjTriggerable && not condAimEnemyTargeted+            && not condDesirableFloorItem )  -- collect the last loot+        , ( runSkills+          , flee actorSk aid (not actorShines) fleeL+          , -- Flee either from melee, if our melee is bad and enemy close,+            -- or from missiles, if we can hide in the dark in one step.+            -- Note that we don't know how far ranged threats are or if,+            -- in fact, they hit from all sides or are hidden. Hence we can't+            -- do much except hide in darkness or take off light (elsewhere).+            -- We tend to flee even when over stash (on lit terrain at least),+            -- but only if we can't fling at enemy (e.g., not visible).+            -- This is OK, since otherwise we'd be killed for free+            -- and the stash would be taken just a little later on.+            -- Note: a part of this condition appears in @actorVulnerable@.+            not condFastThreatAdj+            && fleeingMakesSense+            && if | condAnyHarmfulFoeAdj ->+                    -- Here we don't check @condInMelee@ because regardless+                    -- of whether our team melees (including the fleeing ones),+                    -- endangered actors should flee from very close foes.+                    not condCanMelee+                    || condManyThreatsAdj && not condSupport1 && not condSolo+                  | case gstash fact of+                      Nothing -> False+                      Just (lid2, pos) ->+                        lid2 == lid && chessDist pos (bpos body) <= 2+                        -> False+                  | condInMelee -> False+                      -- No fleeing when others melee and no critical threat+                      -- (otherwise no target nor action would be possible).+                  | heavilyDistressedThisTurn  -- and no adj melee+                    || (heavilyDistressed && not (condThreat 2)) ->+                    not condCanMelee || canFleeIntoDark+                      -- Almost surely hit by projectile. So, if can melee,+                      -- don't escape except into the dark.+                      -- Note that even when in dark now, the projectile hit+                      -- might have been enabled by dynamic light+                      -- or light from lying items, so fleeing still needed.+                      -- If heroes stay in the light when under fire,+                      -- they are pummeled by fast ranged foes and can neither+                      -- flee (too slow) nor force them to flee nor kill them.+                      -- Also AI monsters need predictable behaviour to avoid+                      -- having to chase them forever. Ranged aggravating helps+                      -- and melee-less ranged always fleeing when hit helps+                      -- and makes them evading ambushers, perfect for swarms.+                  | condThreat 2  -- melee enemies near+                    || condThreat 5 && heavilyDistressed ->+                         -- enemies not near but maintain fleeing hysteresis,+                         -- but not if due to lack of support, which changes,+                         -- hence @heavilyDistressed@ and not @recentlyFled@+                    not condCanMelee  -- can't melee, flee+                    || -- No support, not alone, either not aggressive+                       -- or can safely project from afar instead. Flee.+                       not condSupport3+                       && not condSolo+                       -- Don't flee if can spend time productively, killing+                       -- an enemy that blocks projecting or walking.+                       && not condAnyFoeAdj+                       -- Extra random aggressiveness if can't project+                       -- and didn't flee recently and so undecided.+                       -- This is hacky; the randomness is outside @Strategy@.+                       && (condCanProject+                           || recentlyFled  -- still no support, keep fleeing+                           || Ability.getSk Ability.SkAggression actorMaxSk+                              < randomAggressionThreshold)+                  | otherwise -> False )  -- melee threats too far+        , ( runSkills  -- no blockers if can't move right now+          , meleeBlocker actorSk aid  -- only melee blocker+          , abInSkill SkMelee+            && (condAnyFoeAdj  -- if foes, don't displace, otherwise friends:+                || not (abInSkill SkDisplace)  -- displace friends, if can+                   && condAimEnemyOrStash) )  -- excited+                        -- So that animals block each other until hero comes+                        -- and then the stronger makes a show for him+                        -- and kills the weaker.+        , ( [SkAlter]+          , trigger aid ViaNothing+          , not condInMelee  -- don't incur overhead+            && condAdjTriggerable+            && not condAimEnemyTargeted )  -- targeting stash is OK, to unblock+                                           -- dungeons if party has only one key+        , ( [SkDisplace]  -- prevents some looping movement+          , displaceBlocker aid retry  -- fires up only when path blocked+          , retry || not condDesirableFloorItem )+        , ( [SkMelee]+          , meleeAny aid+          , condAnyFoeAdj )  -- won't flee nor displace, so let it melee+        , ( runSkills+          , flee actorSk+                 aid  -- rattlesnakes and hornets flee and return when charging+                 ((heavilyDistressedThisTurn && not condAnyHarmfulFoeAdj+                   || (heavilyDistressed && not (condThreat 2)))+                     -- prefer bad but dark spots if under fire+                  && not actorShines)+                 panicFleeL  -- ultimate panic mode; open tiles, if needed+          , condAnyHarmfulFoeAdj )+        ]+      -- Order doesn't matter, scaling does.+      -- These are flattened in @stratToFreq@ (taking only the best variant)+      -- and then summed, so if any of these can fire, it will.+      -- If none can, @suffix@ is tried.+      -- Only the best variant of @chase@ is taken, but it's almost always+      -- good, and if not, the @chase@ in @suffix@ may fix that.+      -- The scaling values for @stratToFreq@ need to be so low-resolution+      -- or we get 32bit @Freqency@ overflows, which would bite us in JS.+      --+      -- Note that all monadic actions here are performed when the strategy+      -- is being chosen so, e.g., none of them can be @flee@ or the actor+      -- would be marked in state as fleeing even when the strategy is+      -- not chosen.+      distant :: [([Skill], m (Frequency RequestTimed), Bool)]+      distant =+        [ ( [SkMoveItem]+          , stratToFreq (if condInMelee then 20 else 20000)+            $ yieldUnneeded aid  -- 20000 to unequip ASAP, unless is thrown+          , True )+        , ( [SkMoveItem]+          , stratToFreq 10+            $ equipItems aid  -- doesn't take long, very useful if safe+          , not (condInMelee+                 || condDesirableFloorItem+                 || uneasy) )+        , ( [SkProject]+          , stratToFreq (if condTgtNonmovingEnemy then 100 else 30)+              -- not too common, to leave missiles for pre-melee dance+            $ projectItem actorSk aid+          , condAimEnemyTargeted && not condInMelee && condCanProject )+        , ( [SkApply]  -- common, because animals have that+          , stratToFreq 10+            $ applyItem actorSk aid ApplyAll  -- use any potion or scroll+          , condAimEnemyTargeted || condThreat 9 )  -- can buff against enemies+        , ( runSkills+          , stratToFreq (if | condInMelee ->+                              4000  -- friends pummeled by target, go to help+                            | not condAimEnemyOrStash ->+                              20  -- if enemy only remembered investigate anyway+                            | not (isLit (bpos body))  -- would need to leave+                              && not actorShines       -- dark, most probably+                              && condGoalIsLit -> 1+                            | otherwise ->+                              200)+            $ chase actorSk aid avoidAmbient retry+          , condCanMelee+            && Just (lid, bpos body) /= gstash fact+            && (if condInMelee then condAimEnemyOrStash+                else (condAimEnemyOrRemembered+                      || condAimNonEnemyPresent)+                     && (not (condThreat 2)+                         || heavilyDistressed  -- if under fire, do something!+                         || speed >= speedAdd speedWalk speedWalk+                              -- low risk of getting hit first+                         || not condMeleeBad)+                       -- this results in animals in corridor never attacking+                       -- (unless distressed by, e.g., being hit by missiles),+                       -- because they can't swarm opponent, which is logical,+                       -- and in rooms they do attack, so not too boring;+                       -- two aliens attack always, because more aggressive+                     && not condDesirableFloorItem) )+        ]+      suffix =+        [ ( [SkMoveItem]+          , pickup aid False  -- e.g., to give to other party members+          , not condInMelee && condDesirableFloorItem && not dozes )+        , ( [SkMoveItem]+          , unEquipItems aid  -- late, because these items not bad+          , not condInMelee && not dozes )+        , ( [SkWait]+          , waitBlockNow  -- try to fall asleep, rarely+          , bwatch body `notElem` [WSleep, WWake]+            && mayFallAsleep+            && prefersSleep actorMaxSk+            && not condAimCrucial)+        , ( runSkills+          , chase actorSk aid avoidAmbient retry+          , not dozes+            && if condInMelee+               then condCanMelee && condAimEnemyOrStash+               else (not (condThreat 2) || not condMeleeBad)+                    && (Just (lid, bpos body) /= gstash fact+                        || heavilyDistressed  -- guard strictly, until harmed+                        || length oursExploring <= 1+                        || condOurAdj  -- or if teammates adjacent+                        || bcalm body < 10) )  -- break loop, avoid domination+        ]+      fallback =  -- Wait until friends sidestep; ensures strategy never empty.+                  -- Also, this is what non-leader heroes do, unless they melee.+        [ ( [SkWait]+          , case bwatch body of+              WSleep -> yellNow  -- we know actor doesn't want to sleep,+                                 -- so celebrate wake up with a bang+              _ -> waitBlockNow  -- block, etc.+          , True )+        , ( runSkills  -- if can't block, at least change something+          , chase actorSk aid avoidAmbient True+          , not condInMelee || condCanMelee && condAimEnemyTargeted )+        , ( [SkDisplace]  -- if can't brace, at least change something+          , displaceBlocker aid True+          , True )+        , ( []+          , yellNow  -- desperate fallback+          , True )+       ]+  -- Check current, not maximal skills, since this can be a leader as well+  -- as non-leader action.+  let checkAction :: ([Skill], m a, Bool) -> Bool+      checkAction (abts, _, cond) = (null abts || any abInSkill abts) && cond+      sumS :: [([Skill], m a, Bool)] -> [m a]+      sumS abAction =+        let as = filter checkAction abAction+        in map (\(_, m, _) -> m) as+      sumF :: [([Skill], m (Frequency RequestTimed), Bool)]+           -> m (Frequency RequestTimed)+      sumF abFreq = do+        let as = filter checkAction abFreq+        -- This is costly: the monadic side-effects are evaluated.+        -- If we roll an unevaluated one until we find one that is permitted,+        -- keeping track of those aready checked might outweigh the savings.+        -- Even worse, without evaluating per-item frequencies,+        -- applying an amazing item may be disregarded in favour of throwing+        -- a mediocre one.+        strats <- mapM (\(_, m, _) -> m) as+        return $! msum strats+      combineWeighted as = liftFrequency <$> sumF as+      sumPrefix = sumS prefix+      comDistant = combineWeighted distant+      sumSuffix = sumS suffix+      sumFallback = sumS fallback+      -- TODO: should be: sumPrefix .| comDistant .| sumSuffix .| sumFallback+      -- but then all side-effects have to be computed beforehand,+      -- breaking the state, e.g., marking actor as fleeing, always.+      sums = sumPrefix ++ [comDistant] ++ sumSuffix ++ sumFallback+      tryStrategies :: [m (Strategy RequestTimed)] -> m (Strategy RequestTimed)+      tryStrategies [] = return mzero+      tryStrategies (m : rest) = do+        str <- m+        if nullStrategy str+        then tryStrategies rest+        else return str  -- don't perform the remaining monadic actions+  if bwatch body == WSleep+     && abInSkill SkWait+     && mayContinueSleep+       -- no check of @canSleep@, because sight lowered by sleeping+  then return $! returN "sleep" ReqWait+  else tryStrategies sums++waitBlockNow :: MonadClientRead m => m (Strategy RequestTimed)+waitBlockNow = return $! returN "wait" ReqWait++yellNow :: MonadClientRead m => m (Strategy RequestTimed)+yellNow = return $! returN "yell" ReqYell++pickup :: MonadClientRead m => ActorId -> Bool -> m (Strategy RequestTimed)+pickup aid onlyWeapon = do+  benItemL <- benGroundItems aid+  b <- getsState $ getActorBody aid+  -- This calmE is outdated when one of the items increases max Calm+  -- (e.g., in pickup, which handles many items at once), but this is OK,+  -- the server accepts item movement based on calm at the start, not end+  -- or in the middle.+  -- The calmE is inaccurate also if an item not IDed, but that's intended+  -- and the server will ignore and warn (and content may avoid that,+  -- e.g., making all rings identified)+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let calmE = calmEnough b actorMaxSk+      isWeapon (_, _, _, itemFull, _) =+        IA.checkFlag Ability.Meleeable $ aspectRecordFull itemFull+      filterWeapon | onlyWeapon = filter isWeapon+                   | otherwise = id+      prepareOne (oldN, l4)+                 (Benefit{benInEqp}, _, iid, _, (itemK, _)) =+        let prep newN toCStore = (newN, (iid, itemK, CGround, toCStore) : l4)+            n = oldN + itemK+        in if | benInEqp && calmE && not (eqpOverfull b n) -> prep n CEqp+              | onlyWeapon -> (oldN, l4)+              | otherwise -> prep n CStash+      (_, prepared) = foldl' prepareOne (0, []) $ filterWeapon benItemL+  return $! if null prepared then reject+            else returN "pickup" $ ReqMoveItems prepared++-- This only concerns items that can be equipped, that is with a slot+-- and with @benInEqp@ (which implies @goesIntoEqp@).+-- Such items are moved between any stores, as needed. In this case,+-- from stash to eqp.+equipItems :: MonadClientRead m => ActorId -> m (Strategy RequestTimed)+equipItems aid = do+  body <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let calmE = calmEnough body actorMaxSk+  fact <- getsState $ (EM.! bfid body) . sfactionD+  eqpAssocs <- getsState $ kitAssocs aid [CEqp]+  stashAssocs <- getsState $ kitAssocs aid [CStash]+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyOrRemembered <- condAimEnemyOrRememberedM aid+  discoBenefit <- getsClient sdiscoBenefit+  localTime <- getsState $ getLocalTime (blid body)+  fleeD <- getsClient sfleeD+  -- In general, AI always equips the best item in stash if it's better+  -- than the best in equipment. Additionally, if there is space left+  -- in equipment for a future good item, an item from stash may be+  -- equipped if it's not much worse than in equipment.+  -- If the item in question is the best item in stash.+  -- at least one copy must remain in stash.+  let improve :: (Int, [(ItemId, Int, CStore, CStore)])+              -> ( [(Int, (ItemId, ItemFullKit))]+                 , [(Int, (ItemId, ItemFullKit))] )+              -> (Int, [(ItemId, Int, CStore, CStore)])+      improve (oldN, l4) (bestStash, bestEqp) =+        let n = 1 + oldN+        in if eqpOverfull body n then (oldN, l4)+           else case (bestStash, bestEqp) of+             ((_, (iidStash, _)) : _, []) ->+               (n, (iidStash, 1, CStash, CEqp) : l4)+             ((vStash, (iidStash, _)) : _, (vEqp, _) : _) | vStash > vEqp ->+               (n, (iidStash, 1, CStash, CEqp) : l4)+             _ -> case (pluralCopiesOfBest bestStash, bestEqp) of+               ((vStash, (iidStash, _)) : _, (vEqp, _) : _)+                 | not (eqpOverfull body (n + 1))  -- 9 items in equipment+                   && vStash >= vEqp - 20 && vStash > 20 ->+                     -- within 2 damage of the best and not too bad absolutely+                     (n, (iidStash, 1, CStash, CEqp) : l4)+               _ -> (oldN, l4)+      getK (_, (itemK, _)) = itemK+      pluralCopiesOfBest bestStash@((_, (_, itemFullKit)) : rest) =+        if getK itemFullKit > 1 then bestStash else rest+      pluralCopiesOfBest [] = []+      heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltasSerious (bcalmDelta body)+      recentlyFled = maybe False (\(_, time) -> timeRecent5 localTime time)+                           (aid `EM.lookup` fleeD)+      uneasy = condAimEnemyOrRemembered+               || not calmE+               || heavilyDistressed+               || recentlyFled+      canEsc = fcanEscape (gkind fact)+      -- We filter out unneeded items. In particular, we ignore them in eqp+      -- when comparing to items we may want to equip, so that the unneeded+      -- but powerful items don't fool us.+      -- In any case, the unneeded items should be removed from equip+      -- in @yieldUnneeded@ earlier or soon after this check.+      -- In other stores we need to filter, for otherwise we'd have+      -- a loop of equip/yield.+      filterNeeded (_, (itemFull, _)) =+        not (hinders condShineWouldBetray uneasy actorMaxSk itemFull+             || not canEsc && IA.isHumanTrinket (itemKind itemFull))+                  -- don't equip items that block progress, e.g., blowtorch+      bestTwo = bestByEqpSlot discoBenefit+                              (filter filterNeeded stashAssocs)+                              (filter filterNeeded eqpAssocs)+      bEqpStash = foldl' improve (0, []) bestTwo+      (_, prepared) = bEqpStash+  return $! if not calmE || null prepared+            then reject+            else returN "equipItems" $ ReqMoveItems prepared++yieldUnneeded :: MonadClientRead m => ActorId -> m (Strategy RequestTimed)+yieldUnneeded aid = do+  body <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let calmE = calmEnough body actorMaxSk+  eqpAssocs <- getsState $ kitAssocs aid [CEqp]+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyOrRemembered <- condAimEnemyOrRememberedM aid+  discoBenefit <- getsClient sdiscoBenefit+  localTime <- getsState $ getLocalTime (blid body)+  fleeD <- getsClient sfleeD+  -- Here and in @unEquipItems@ AI may hide from the human player,+  -- in shared stash, the Ring of Speed And Bleeding,+  -- which is a bit harsh, but fair. However any subsequent such+  -- rings will not be picked up at all, so the human player+  -- doesn't lose much fun. Additionally, if AI learns alchemy later on,+  -- they can repair the ring, wield it, drop at death and it's+  -- in play again.+  let heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltasSerious (bcalmDelta body)+      recentlyFled = maybe False (\(_, time) -> timeRecent5 localTime time)+                           (aid `EM.lookup` fleeD)+      uneasy = condAimEnemyOrRemembered+               || not calmE+               || heavilyDistressed+               || recentlyFled+      yieldSingleUnneeded (iidEqp, (itemEqp, (itemK, _))) =+        [ (iidEqp, itemK, CEqp, CStash)+        | harmful discoBenefit iidEqp  -- harmful not shared+          || hinders condShineWouldBetray uneasy actorMaxSk itemEqp ]+      yieldAllUnneeded = concatMap yieldSingleUnneeded eqpAssocs+  return $! if not calmE || null yieldAllUnneeded+            then reject+            else returN "yieldUnneeded" $ ReqMoveItems yieldAllUnneeded++-- This only concerns items that @equipItems@ handles, that is+-- with a slot and with @benInEqp@ (which implies @goesIntoEqp@).+unEquipItems :: MonadClientRead m => ActorId -> m (Strategy RequestTimed)+unEquipItems aid = do+  body <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let calmE = calmEnough body actorMaxSk+  eqpAssocs <- getsState $ kitAssocs aid [CEqp]+  stashAssocs <- getsState $ kitAssocs aid [CStash]+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyOrRemembered <- condAimEnemyOrRememberedM aid+  discoBenefit <- getsClient sdiscoBenefit+  localTime <- getsState $ getLocalTime (blid body)+  fleeD <- getsClient sfleeD+  -- In general, AI unequips only if equipment is full and better stash item+  -- for another slot is likely to come or if the best (or second best)+  -- item in stash is worse than in equipment and at least one better+  -- item remains in equipment.+  let improve :: ( [(Int, (ItemId, ItemFullKit))]+                 , [(Int, (ItemId, ItemFullKit))] )+              -> [(ItemId, Int, CStore, CStore)]+      improve (bestStash, bestEqp) =+        case bestEqp of+          ((_, (iidEqp, itemEqp)) : _) | getK itemEqp > 1+                                         && bestStash `worseThanEqp` bestEqp ->+            -- To share the best items with others, if they care+            -- and if a better or equal item is not already in stash.+            -- The effect is that after each party member has a copy,+            -- a single copy is permanently kept in stash, to quickly+            -- equip a new-joiner.+            [(iidEqp, 1, CEqp, CStash)]+          _ : bestEqp2@((_, (iidEqp, itemEqp)) : _)+            | getK itemEqp > 1+              && bestStash `worseThanEqp` bestEqp2 ->+            -- To share the second best items with others, if they care+            -- and if a better or equal item is not already in stash.+            -- The effect is the same as with the rule above, but only as long+            -- as the best item is scarce. Then this rule doesn't fire and+            -- every second best item copy is eventually equipped by someone.+            [(iidEqp, getK itemEqp, CEqp, CStash)]+          _ -> case reverse bestEqp of+            bestEqpR@((vEqp, (iidEqp, itemEqp)) : _)+              | eqpOverfull body 1  -- 10 items in equipment+                && (bestStash `betterThanEqp` bestEqpR+                    || getK itemEqp > 1 && vEqp < 20) ->+              -- To make place in eqp for an item better than any ours.+              -- Even a minor boost is removed only if stash has a better one.+              -- Also remove extra copies if the item weak, ih hopes+              -- of a prompt better pickup.+              [(iidEqp, 1, CEqp, CStash)]+            _ -> []+      getK (_, (itemK, _)) = itemK+      worseThanEqp ((vStash, _) : _) ((vEqp, _) : _) = vStash < vEqp+      worseThanEqp [] _ = True+      worseThanEqp _ [] = error "unEquipItems: worseThanEqp: []"+      -- Not @>=@ or we could remove a useful item, without replacing it+      -- with a better or even equal one. We only remove it so if the item+      -- is weak and duplicated in equipment.+      betterThanEqp ((vStash, _) : _) ((vEqp, _) : _) = vStash > vEqp+      betterThanEqp [] _ = False+      betterThanEqp _ [] = error "unEquipItems: betterThanEqp: []"+      heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltasSerious (bcalmDelta body)+      recentlyFled = maybe False (\(_, time) -> timeRecent5 localTime time)+                           (aid `EM.lookup` fleeD)+      uneasy = condAimEnemyOrRemembered+               || not calmE+               || heavilyDistressed+               || recentlyFled+      -- Here we don't need to filter out items that hinder (except in stash)+      -- because they are moved to stash and will be equipped by another actor+      -- at another time, where hindering will be completely different.+      -- If they hinder and we unequip them, all the better.+      -- We filter stash to consider only eligible items in @betterThanEqp@.+      filterNeeded (_, (itemFull, _)) =+        not $ hinders condShineWouldBetray uneasy actorMaxSk itemFull+      bestTwo = bestByEqpSlot discoBenefit+                              (filter filterNeeded stashAssocs)+                              eqpAssocs+      bEqpStash = concatMap improve bestTwo+  return $! if not calmE || null bEqpStash+            then reject+            else returN "unEquipItems" $ ReqMoveItems bEqpStash++groupByEqpSlot :: [(ItemId, ItemFullKit)]+               -> EM.EnumMap EqpSlot [(ItemId, ItemFullKit)]+groupByEqpSlot is =+  let f (iid, itemFullKit) =+        let arItem = aspectRecordFull $ fst itemFullKit+        in case IA.aEqpSlot arItem of+          Nothing -> Nothing+          Just es -> Just (es, [(iid, itemFullKit)])+      withES = mapMaybe f is+  in EM.fromListWith (++) withES++bestByEqpSlot :: DiscoveryBenefit+              -> [(ItemId, ItemFullKit)]+              -> [(ItemId, ItemFullKit)]+              -> [( [(Int, (ItemId, ItemFullKit))]+                  , [(Int, (ItemId, ItemFullKit))] )]+bestByEqpSlot discoBenefit eqpAssocs stashAssocs =+  let eqpMap = EM.map (\g -> (g, [])) $ groupByEqpSlot eqpAssocs+      stashMap = EM.map (\g -> ([], g)) $ groupByEqpSlot stashAssocs+      appendTwo (g1, g2) (h1, h2) = (g1 ++ h1, g2 ++ h2)+      eqpStashMap = EM.unionsWith appendTwo [eqpMap, stashMap]+      bestSingle = strongestSlot discoBenefit+      bestTwo eqpSlot (g1, g2) = (bestSingle eqpSlot g1, bestSingle eqpSlot g2)+  in EM.elems $ EM.mapWithKey bestTwo eqpStashMap++harmful :: DiscoveryBenefit -> ItemId -> Bool+harmful discoBenefit iid =+  -- Items that are known, perhaps recently discovered, and it's now revealed+  -- they should not be kept in equipment, should be unequipped+  -- (either they are harmful or they waste eqp space).+  not $ benInEqp $ discoBenefit EM.! iid++-- If enemy (or even a friend) blocks the way, sometimes melee him+-- even though normally you wouldn't.+-- This is also a trick to make a foe use up its non-durable weapons,+-- e.g., on cheap slow projectiles fired in its path.+meleeBlocker :: MonadClient m+             => Ability.Skills -> ActorId -> m (Strategy RequestTimed)+meleeBlocker actorSk aid = do+  b <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  case mtgtMPath of+    Just TgtAndPath{ tapTgt=TEnemy{}+                   , tapPath=Just AndPath{pathList=q : _, pathGoal} }+      | q == pathGoal -> return reject+        -- not a real blocker, but goal enemy, so defer deciding whether+        -- to melee him to the code that deals with goal enemies+    Just TgtAndPath{tapPath=Just AndPath{pathList=q : _, pathGoal}} -> do+      -- We prefer the goal position, so that we can kill the foe and enter it,+      -- but we accept any @q@ as well.+      lvl <- getLevel (blid b)+      let maim | adjacent (bpos b) pathGoal = Just pathGoal+               | adjacent (bpos b) q = Just q+               | otherwise = Nothing  -- MeleeDistant+          lBlocker = case maim of+            Nothing -> []+            Just aim -> posToAidsLvl aim lvl+      case lBlocker of+        aid2 : _ -> do+          body2 <- getsState $ getActorBody aid2+          actorMaxSk2 <- getsState $ getActorMaxSkills aid2+          -- No problem if there are many projectiles at the spot. We just+          -- attack the first one.+          if | bproj body2  -- displacing saves a move, so don't melee+               && getSk SkDisplace actorSk > 0 ->+               return reject+             | isFoe (bfid b) fact (bfid body2)+                 -- at war with us, so hit, not displace+               || isFriend (bfid b) fact (bfid body2) -- don't start a war+                  && getSk SkDisplace actorSk <= 0+                       -- can't displace+                  && getSk SkMove actorSk > 0  -- blocked move+                  && 3 * bhp body2 < bhp b  -- only get rid of weak friends+                  && gearSpeed actorMaxSk2 <= gearSpeed actorMaxSk -> do+               mel <- maybeToList <$> pickWeaponClient aid aid2+               return $! liftFrequency $ uniformFreq "melee in the way" mel+             | otherwise -> return reject+        [] -> return reject+    _ -> return reject  -- probably no path to the enemy, if any++-- Everybody melees in a pinch, skills and weapons allowing,+-- even though some prefer ranged attacks. However only potentially harmful+-- enemies or those having loot or moving (can follow and spy) are meleed+-- (or those that are in the way, see elsewhere).+-- Projectiles are rather displaced or sidestepped, because it's cheaper+-- and also the projectile may be explosive and so harm anyway+-- and also if ignored it may hit enemies --- AI can't tell.+meleeAny :: MonadClient m => ActorId -> m (Strategy RequestTimed)+meleeAny aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  adjBigAssocs <- getsState $ adjacentBigAssocs b+  actorMaxSkills <- getsState sactorMaxSkills+  let foe b2 = isFoe (bfid b) fact (bfid b2)+      adjFoes = filter (uncurry $ actorWorthKilling actorMaxSkills)+                $ filter (foe . snd) adjBigAssocs+  btarget <- getsClient $ getTarget aid+  mtargets <- case btarget of+    Just (TEnemy aid2) -> do+      b2 <- getsState $ getActorBody aid2+      return $! if adjacent (bpos b2) (bpos b)+                   && actorWorthKilling actorMaxSkills aid2 b2+                then Just [(aid2, b2)]+                else Nothing+    _ -> return Nothing+  let adjTargets = fromMaybe adjFoes mtargets+  mels <- mapM (pickWeaponClient aid . fst) adjTargets+  let freq = uniformFreq "melee adjacent" $ catMaybes mels+  return $! liftFrequency freq++-- The level the actor is on is either explored or the actor already+-- has a weapon equipped, so no need to explore further, he tries to find+-- enemies on other levels, hence triggering terrain.+-- We don't verify any embedded item is targeted by the actor, but at least+-- the actor doesn't target a visible enemy at this point.+-- TODO: In @actionStrategy@ we require minimal @SkAlter@ even for the case+-- of triggerable tile underfoot. Let's say this quirk is a specialization+-- of AI actors, because there are usually many, so not all need to trigger.+trigger :: MonadClientRead m+        => ActorId -> FleeViaStairsOrEscape+        -> m (Strategy RequestTimed)+trigger aid fleeVia = do+  b <- getsState $ getActorBody aid+  lvl <- getLevel (blid b)+  let f pos = case EM.lookup pos $ lembed lvl of+        Nothing -> Nothing+        Just bag -> Just (pos, bag)+      pbags = mapMaybe f $ bpos b : vicinityUnsafe (bpos b)+  efeat <- embedBenefit fleeVia aid pbags+  return $! liftFrequency $ toFreq "trigger"+    [ (ceiling benefit, ReqAlter pos)+    | (benefit, (pos, _)) <- efeat+    , let underFeet = pos == bpos b+    , underFeet+      || not (occupiedBigLvl pos lvl)+         && not (occupiedProjLvl pos lvl) -- AlterBlockActor+         && EM.notMember pos (lfloor lvl) ]  -- AlterBlockItem++projectItem :: MonadClientRead m+            => Ability.Skills -> ActorId -> m (Strategy RequestTimed)+projectItem actorSk aid = do+  btarget <- getsClient $ getTarget aid+  b <- getsState $ getActorBody aid+  -- We query target, not path, because path is not needed for flinging.+  -- Even if unknown tiles exist between us and the target, we assume+  -- they are walkable and not just transparent and we happily try to shoot.+  mfpos <- getsState $ aidTgtToPos (Just aid) (blid b) btarget+  case (btarget, mfpos) of+    (_, Just fpos) | adjacent (bpos b) fpos -> return reject+    (Just (TEnemy aidE), Just fpos) -> do+      actorMaxSkills <- getsState sactorMaxSkills+      body <- getsState $ getActorBody aidE+      if actorWorthChasing actorMaxSkills aidE body then do+        cops <- getsState scops+        lvl <- getLevel (blid b)+        seps <- getsClient seps+        case makeLine False b fpos seps cops lvl of+          Just newEps -> do+            let skill = getSk SkProject actorSk+            -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain+            -- and no actors or obstacles along the path.+            benList <- condProjectListM skill aid+            localTime <- getsState $ getLocalTime (blid b)+            let fRanged (benR, cstore, iid, itemFull, kit) =+                  -- If the item is discharged, neither the kinetic hit nor+                  -- any effects activate, so no point projecting.+                  -- This changes in time, so recharging is not included+                  -- in @condProjectListM@, but checked here, just before fling.+                  let recharged = hasCharge localTime kit+                      arItem = aspectRecordFull itemFull+                      trange = IA.totalRange arItem $ itemKind itemFull+                      bestRange =+                        chessDist (bpos b) fpos + 2  -- margin for fleeing+                      rangeMult =  -- penalize wasted or unsafely low range+                        10 + max 0 (10 - abs (trange - bestRange))+                  in if trange >= chessDist (bpos b) fpos && recharged+                     then Just ( - ceiling (benR * intToDouble rangeMult / 10)+                               , ReqProject fpos newEps iid cstore )+                     else Nothing+                benRanged = mapMaybe fRanged benList+            return $! liftFrequency $ toFreq "projectItem" benRanged+          _ -> return reject+      else return reject+    _ -> return reject++data ApplyItemGroup = ApplyAll | ApplyFirstAid+  deriving Eq++applyItem :: MonadClientRead m+          => Ability.Skills -> ActorId -> ApplyItemGroup+          -> m (Strategy RequestTimed)+applyItem actorSk aid applyGroup = do+  COps{corule} <- getsState scops+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  condShineWouldBetray <- condShineWouldBetrayM aid+  condAimEnemyOrRemembered <- condAimEnemyOrRememberedM aid+  localTime <- getsState $ getLocalTime (blid b)+  let calmE = calmEnough b actorSk+      heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.+        deltasSerious (bcalmDelta b)+      uneasy = condAimEnemyOrRemembered+               || not calmE+               || heavilyDistressed+        -- don't take recent fleeing into account when item can be lost+      skill = getSk SkApply actorSk+      -- This detects if the value of keeping the item in eqp is in fact < 0.+      hind = hinders condShineWouldBetray uneasy actorSk+      canEsc = fcanEscape (gkind fact)+      permittedActor cstore itemFull kit =+        fromRight False+        $ permittedApply corule localTime skill calmE cstore itemFull kit+      disqualify :: Bool -> IK.Effect -> Bool+      -- These effects tweak items, which is only situationally beneficial+      -- and not really the best idea while in combat.+      disqualify _ IK.PolyItem = True+      disqualify _ IK.RerollItem = True+      disqualify _ IK.DupItem = True+      disqualify _ IK.Identify = True+      -- This is hard to use and would be wasted recharging stomach.+      disqualify _ IK.Recharge{} = True+      -- This is usually the main effect of item and it's useless without Calm.+      disqualify durable IK.Summon{} =+        durable && (bcalm b < xM 30 || not calmE)+      disqualify durable (IK.AtMostOneOf l) = any (disqualify durable) l+      disqualify durable (IK.OneOf l) = any (disqualify durable) l+      disqualify durable (IK.OnUser eff) = disqualify durable eff+      disqualify durable (IK.AndEffect eff1 eff2) =+        disqualify durable eff1 || disqualify durable eff2+      disqualify durable (IK.OrEffect eff1 eff2) =+        disqualify durable eff1 || disqualify durable eff2+      disqualify durable (IK.SeqEffect effs) = any (disqualify durable) effs+      disqualify durable (IK.When _ eff) = disqualify durable eff+      disqualify durable (IK.Unless _ eff) = disqualify durable eff+      disqualify durable (IK.IfThenElse _ eff1 eff2) =+        disqualify durable eff1 || disqualify durable eff2+      disqualify _ _ = False+      q (Benefit{benInEqp}, cstore, _, itemFull@ItemFull{itemKind}, kit) =+        let arItem = aspectRecordFull itemFull+            durable = IA.checkFlag Durable arItem+        in (not benInEqp  -- can't wear, so OK to break+            || durable  -- can wear, but can't break, even better+            || not (IA.checkFlag Ability.Meleeable arItem)+                 -- anything else expendable+               && hind itemFull)  -- hinders now, so possibly often, so away!+           && permittedActor (Just cstore) itemFull kit+           && not (any (disqualify durable) $ IK.ieffects itemKind)+           && (canEsc || not (IA.isHumanTrinket itemKind))+                -- A hack to prevent monsters from using up treasure+                -- meant for heroes.+      stores = [CStash, CGround, COrgan] ++ [CEqp | calmE]+  discoBenefit <- getsClient sdiscoBenefit+  benList <- getsState $ benAvailableItems discoBenefit aid stores+  getKind <- getsState $ flip getIidKind+  let (myBadGrps, myGoodGrps) = partitionEithers $ mapMaybe (\iid ->+        let itemKind = getKind iid+        in if maybe False (> 0) $ lookup IK.CONDITION $ IK.ifreq itemKind+           then Just $ if benInEqp (discoBenefit EM.! iid)+                       then Right $ DefsInternal.GroupName $ IK.iname itemKind+                         -- conveniently, @iname@ matches @ifreq@+                       else Left $ DefsInternal.GroupName $ IK.iname itemKind+           else Nothing) (EM.keys $ borgan b)+      fTool benAv@( Benefit{benApply}, cstore, iid+                  , itemFull@ItemFull{itemKind}, _ ) =+        let dropsGrps = IK.getDropOrgans itemKind  -- @Impress@ effect included+            dropsBadOrgans =+              not (null myBadGrps)+              && (IK.CONDITION `elem` dropsGrps+                  || not (null (dropsGrps `intersect` myBadGrps)))+            dropsImpressed =+              IK.S_IMPRESSED `elem` myBadGrps+              && (IK.CONDITION `elem` dropsGrps+                  || IK.S_IMPRESSED `elem` dropsGrps)+            dropsGoodOrgans =+              not (null myGoodGrps)+              && (IK.CONDITION `elem` dropsGrps+                  || not (null (dropsGrps `intersect` myGoodGrps)))+            wastesDrop = not dropsBadOrgans && not (null dropsGrps)+            -- Don't include @Ascend@ nor @Teleport@, because maybe no foe near.+            -- Don't include @AtMostOneOf@ nor @OneOf@ because+            -- other effects may kill you.+            getHP (IK.RefillHP p) = max 0 p+            getHP (IK.OnUser eff) = getHP eff+            getHP (IK.AndEffect eff1 eff2) = getHP eff1 + getHP eff2+            getHP (IK.OrEffect eff1 _) = getHP eff1+            getHP (IK.SeqEffect effs) = sum $ map getHP effs+            getHP (IK.When _ eff) = getHP eff+            getHP (IK.Unless _ eff) = getHP eff+            getHP (IK.IfThenElse _ eff1 eff2) = getHP eff1 + getHP eff2+            getHP _ = 0+            healPower = sum $ map getHP $ IK.ieffects itemKind+            wastesHP = xM healPower+                       > xM (Ability.getSk Ability.SkMaxHP actorSk) - bhp b+            durable = IA.checkFlag Durable $ aspectRecordFull itemFull+            situationalBenApply =+              if | dropsBadOrgans -> if dropsImpressed+                                     then benApply + 1000  -- crucial+                                     else benApply + 20+                 | wastesDrop || wastesHP -> benApply - 10+                 | otherwise -> benApply+            coeff CGround = 2  -- pickup turn saved+            coeff COrgan = if durable then 1 else 1000+              -- if not durable, must hinder currently or be very potent+            coeff CEqp = if durable then 1 else 1000+            coeff CStash = 1+            benR = ceiling situationalBenApply * coeff cstore+            canApply =+              situationalBenApply > 0+              && (dropsImpressed || not wastesHP)+                -- waste healing only if it drops impressed;+                -- otherwise apply anything beneficial at will+              && case applyGroup of+                ApplyFirstAid -> q benAv && (healPower > 0 || dropsImpressed)+                  -- when low HP, Calm easy to deplete, so impressed crucial+                ApplyAll -> q benAv && not dropsGoodOrgans+                  -- not an emergency, so don't sacrifice own good conditions+        in if canApply+           then Just (benR, ReqApply iid cstore)+           else Nothing+      benTool = mapMaybe fTool benList+  return $! liftFrequency $ toFreq "applyItem" benTool++-- If low on health or alone, flee in panic, close to the path to target+-- and as far from the attackers, as possible. Usually fleeing from+-- foes will lead towards friends, but we don't insist on that.+flee :: MonadClient m+     => Ability.Skills -> ActorId -> Bool -> [(Int, Point)]+     -> m (Strategy RequestTimed)+flee actorSk aid avoidAmbient fleeL = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  localTime <- getsState $ getLocalTime (blid b)+  fleeD <- getsClient sfleeD+  let recentlyFled = maybe False (\(_, time) -> timeRecent5 localTime time)+                           (aid `EM.lookup` fleeD)+  -- Regardless if fleeing accomplished, mark the need, but don't forget+  -- the location of initial danger, in case enemies not seen any more,+  -- if not too old.+  unless recentlyFled $+    modifyClient $ \cli ->+      cli {sfleeD = EM.insert aid (bpos b, localTime) (sfleeD cli)}+  lvl <- getLevel $ blid b+  let isAmbient pos = Tile.isLit coTileSpeedup (lvl `at` pos)+                      && Tile.isWalkable coTileSpeedup (lvl `at` pos)+                        -- if solid, will be altered and perhaps darkened+      fleeAmbientAvoided = filter (not . isAmbient . snd) fleeL+      fleeAmbient = if avoidAmbient && not (null fleeAmbientAvoided)+                    then fleeAmbientAvoided+                    else fleeL+  let vVic = map (second (`vectorToFrom` bpos b)) fleeAmbient+      str = liftFrequency $ toFreq "flee" vVic+  mapStrategyM (moveOrRunAid actorSk aid) str++-- The result of all these conditions is that AI displaces rarely,+-- but it can't be helped as long as the enemy is smart enough to form fronts.+displaceFoe :: MonadClientRead m => ActorId -> m (Strategy RequestTimed)+displaceFoe aid = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  fact <- getsState $ (EM.! bfid b) . sfactionD+  friends <- getsState $ friendRegularList (bfid b) (blid b)+  adjBigAssocs <- getsState $ adjacentBigAssocs b+  let foe (_, b2) = isFoe (bfid b) fact (bfid b2)+      adjFoes = filter foe adjBigAssocs+      walkable p =  -- DisplaceAccess+        Tile.isWalkable coTileSpeedup (lvl `at` p)+      nFriends body = length $ filter (adjacent (bpos body) . bpos) friends+      nFrNew = nFriends b + 1+      qualifyActor (aid2, b2) = do+        case posToAidsLvl (bpos b2) lvl of+          _ | not (walkable (bpos b2))  -- DisplaceAccess+              || boldpos b == Just (bpos b2)+                 && boldpos b2 == Just (bpos b) ->  -- avoid short loops+              return Nothing+          [_] -> do+            actorMaxSk <- getsState $ getActorMaxSkills aid2+            dEnemy <- getsState $ dispEnemy aid aid2 actorMaxSk+              -- DisplaceDying, DisplaceBraced, DisplaceImmobile,+              -- DisplaceSupported+            let nFrOld = nFriends b2+            return $! if dEnemy && nFrOld < nFrNew+                      then Just ( (nFrNew - nFrOld) ^ (2 :: Int)+                                , ReqDisplace aid2 )+                      else Nothing+          _ -> return Nothing  -- DisplaceProjectiles+  foes <- mapM qualifyActor adjFoes+  return $! liftFrequency $ toFreq "displaceFoe" $ catMaybes foes++displaceBlocker :: MonadClientRead m => ActorId -> Bool -> m (Strategy RequestTimed)+displaceBlocker aid retry = do+  b <- getsState $ getActorBody aid+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  case mtgtMPath of+    Just TgtAndPath{ tapTgt=TEnemy{}+                   , tapPath=Just AndPath{pathList=q : _, pathGoal} }+      | q == pathGoal  -- not a real blocker but goal; only try to displace+                       -- if desperate (that is, already tried to melee it)+        && not retry ->+        return reject+    Just TgtAndPath{tapPath=Just AndPath{pathList=q : _}}+      | adjacent (bpos b) q ->  -- not veered off target too much+        displaceTgt aid q retry+    _ -> return reject  -- goal reached++displaceTgt :: MonadClientRead m+            => ActorId -> Point -> Bool -> m (Strategy RequestTimed)+displaceTgt source tpos retry = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody source+  actorMaxSkills <- getsState sactorMaxSkills+  let !_A = assert (adjacent (bpos b) tpos) ()+  lvl <- getLevel $ blid b+  let walkable p =  -- DisplaceAccess+        Tile.isWalkable coTileSpeedup (lvl `at` p)+  case posToAidsLvl tpos lvl of+    _ | not (walkable tpos) -> return reject  -- DisplaceAccess+    [aid2] -> do+      b2 <- getsState $ getActorBody aid2+      mleader <- getsClient sleader+      if | bwatch b2 `elem` [WSleep, WWake] ->+             return $! returN "displace sleeping" $ ReqDisplace aid2+         | Just aid2 == mleader -> return reject+         | boldpos b == Just tpos+           && boldpos b2 == Just (bpos b) ->+             return reject  -- avoid short loops+         | otherwise -> do+           tfact <- getsState $ (EM.! bfid b2) . sfactionD+           mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD+           enemyTgt <- condAimEnemyOrRememberedM source+           enemyTgt2 <- condAimEnemyOrRememberedM aid2+           case mtgtMPath of+             -- I can see targets of only own team, so no check of @bfid@.+             Just TgtAndPath{tapPath=Just AndPath{pathList=q : _}}+               | q == bpos b ->  -- teammate wants to swap+                 return $! returN "displace mutual" $ ReqDisplace aid2+             Just _ -> return $!+               -- Teammate, possibly without path, for whatever reason.+               if retry  -- me desperate+                  || Just (blid b2, bpos b2) == gstash tfact  -- guarding; lazy+                  || getSk SkDisplace (actorMaxSkills EM.! aid2) <= 0+                       -- can't displace back+                  || enemyTgt && not enemyTgt2+                       -- he doesn't have Enemy target and I have, so push him+                       -- aside, because, for heroes, he will never be a leader,+                       -- so he can't step aside himself+               then returN "displace teammate" $ ReqDisplace aid2+               else reject+             _ -> do  -- an enemy or ally or disoriented teammate+               actorMaxSk <- getsState $ getActorMaxSkills aid2+               dEnemy <- getsState $ dispEnemy source aid2 actorMaxSk+                 -- DisplaceDying, DisplaceBraced, DisplaceImmobile,+                 -- DisplaceSupported+               return $!+                 if bfid b == bfid b2  -- disoriented teammate; doesn't care+                    || isFoe (bfid b2) tfact (bfid b) && dEnemy  -- foe+                    || retry  -- ally, I need to be desperate, as above+                 then returN "displace other" $ ReqDisplace aid2+                 else reject+    _ -> return reject  -- DisplaceProjectiles and no blocker at all++chase :: MonadClientRead m+      => Ability.Skills -> ActorId -> Bool -> Bool -> m (Strategy RequestTimed)+chase actorSk aid avoidAmbient retry = do+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  let -- With no leader, the goal is vague, so permit arbitrary detours.+      relaxed = not $ fhasPointman (gkind fact)+      strAmbient avoid = case mtgtMPath of+        Just TgtAndPath{tapPath=Just AndPath{pathList=q : _, ..}} ->+          if pathGoal == bpos body+          then return reject  -- done; picking up items, etc.+          else moveTowards actorSk aid avoid q pathGoal (relaxed || retry)+        _ -> return reject  -- goal reached or banned ambient lit tile+  strAvoided <- strAmbient avoidAmbient+  str <- if avoidAmbient && nullStrategy strAvoided+         then strAmbient False+         else return strAvoided+  mapStrategyM (moveOrRunAid actorSk aid) str++moveTowards :: MonadClientRead m+            => Ability.Skills -> ActorId -> Bool -> Point -> Point -> Bool+            -> m (Strategy Vector)+moveTowards actorSk aid avoidAmbient target goal relaxed = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let source = bpos b+      alterSkill = getSk SkAlter actorSk+      !_A = assert (adjacent source target+                    `blame` (source, target, aid, b, goal)) ()+  fact <- getsState $ (EM.! bfid b) . sfactionD+  salter <- getsClient salter+  noFriends <- getsState $ \s p ->+    all (isFoe (bfid b) fact . bfid . snd)+        (posToAidAssocs p (blid b) s)  -- don't kill own projectiles+  let lalter = salter EM.! blid b+      isAmbient pos = Tile.isLit coTileSpeedup (lvl `at` pos)+                      && Tile.isWalkable coTileSpeedup (lvl `at` pos)+                        -- if solid, will be altered and perhaps darkened+      -- Only actors with SkAlter can search for hidden doors, etc.+      enterableHere p = alterSkill >= fromEnum (lalter PointArray.! p)+      permittedHere p | avoidAmbient = enterableHere p && not (isAmbient p)+                      | otherwise = enterableHere p+  -- If target is the final goal, is not occupied and is lit, permit+  -- movement into lit position, regardless.+  if noFriends target && (target == goal && enterableHere target+                          || permittedHere target) then+    return $! returN "moveTowards target" $ target `vectorToFrom` source+  else do+    -- This lets animals mill around, even when blocked,+    -- because they have nothing to lose (unless other animals melee).+    -- Blocked heroes instead don't become leaders and don't move+    -- until friends sidestep to let them reach their goal.+    let goesBack p = Just p == boldpos b+        nonincreasing p = chessDist source goal >= chessDist p goal+        isSensible | relaxed = \p -> noFriends p+                                     && permittedHere p+                   | otherwise = \p -> nonincreasing p+                                       && not (goesBack p)+                                       && noFriends p+                                       && permittedHere p+        sensible = [ ((goesBack p, chessDist p goal), v)+                   | v <- moves+                   , let p = source `shift` v+                   , isSensible p ]+        -- @SortOn@ less efficient here, because function cheap.+        sorted = sortBy (comparing fst) sensible+        groups = map (map snd) $ groupBy ((==) `on` fst) sorted+        freqs = map (liftFrequency . uniformFreq "moveTowards") groups+    return $! foldr (.|) reject freqs++-- Actor moves or searches or alters or attacks.+-- This function is very general, even though it's often used in contexts+-- when only one or two of the many cases can possibly occur.+moveOrRunAid :: MonadClientRead m+             => Ability.Skills -> ActorId -> Vector -> m (Maybe RequestTimed)+moveOrRunAid actorSk source dir = do+  COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+  lvl <- getLevel lid+  let walkable =  -- DisplaceAccess+        Tile.isWalkable coTileSpeedup (lvl `at` tpos)+      notLooping body p =  -- avoid displace loops+        boldpos body /= Just p || actorWaits body+      spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+      t = lvl `at` tpos+  -- We start by checking actors at the target position,+  -- which gives a partial information (actors can be invisible),+  -- as opposed to accessibility (and items) which are always accurate+  -- (tiles can't be invisible).+  case posToAidsLvl tpos lvl of+    [target] | walkable+               && getSk SkDisplace actorSk > 0+               && notLooping sb tpos -> do+      -- @target@ can be a foe, as well as a friend.+      tb <- getsState $ getActorBody target+      tfact <- getsState $ (EM.! bfid tb) . sfactionD+      actorMaxSk <- getsState $ getActorMaxSkills target+      dEnemy <- getsState $ dispEnemy source target actorMaxSk+        -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported+      if isFoe (bfid tb) tfact (bfid sb) && not dEnemy+      then return Nothing+      else return $ Just $ ReqDisplace target+    [] | walkable && getSk SkMove actorSk > 0 ->+      -- Movement requires full access. The potential invisible actor is hit.+      return $ Just $ ReqMove dir+    [] | not walkable+         && getSk SkAlter actorSk+              >= Tile.alterMinWalk coTileSpeedup t  -- AlterUnwalked+         -- Only possible if items allowed inside unwalkable tiles:+         && EM.notMember tpos (lfloor lvl) ->  -- AlterBlockItem+      -- Not walkable, but alter skill suffices, so search or alter the tile.+      -- We assume that unalterable unwalkable tiles are protected by high+      -- skill req. We don't alter walkable tiles (e.g., to close doors).+      return $ Just $ ReqAlter tpos+    _ -> return Nothing  -- can't displace, move nor alter
+ engine-src/Game/LambdaHack/Client/AI/PickActorM.hs view
@@ -0,0 +1,426 @@+-- | Picking the AI actor to move and refreshing leader and non-leader targets.+module Game.LambdaHack.Client.AI.PickActorM+  ( pickActorToMove, setTargetFromDoctrines+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import           Data.Ratio++import           Game.LambdaHack.Client.AI.ConditionM+import           Game.LambdaHack.Client.AI.PickTargetM+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.FactionKind (fskillsOther)+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability++-- | Pick a new leader from among the actors on the current level.+-- Refresh the target of the new leader, even if unchanged.+pickActorToMove :: MonadClient m+                => [(ActorId, Actor)] -> [(ActorId, Actor)] -> Maybe ActorId+                -> m ActorId+pickActorToMove foeAssocs friendAssocs maidToAvoid = do+  COps{coTileSpeedup} <- getsState scops+  actorMaxSkills <- getsState sactorMaxSkills+  mleader <- getsClient sleader+  let oldAid = fromMaybe (error $ "" `showFailure` maidToAvoid) mleader+  oldBody <- getsState $ getActorBody oldAid+  let side = bfid oldBody+      arena = blid oldBody+  lvl <- getLevel arena+  localTime <- getsState $ getLocalTime arena+  condInMelee <- condInMeleeM arena+  fact <- getsState $ (EM.! side) . sfactionD+  -- Find our actors on the current level only.+  ours <- getsState $ fidActorRegularAssocs side arena+  let pickOld = do+        void $ refreshTarget foeAssocs friendAssocs (oldAid, oldBody)+        return oldAid+      oursNotSleeping = filter (\(_, b) -> bwatch b /= WSleep) ours+      -- Faction discourages client leader change on level, because+      -- non-leader actors have the same skills as leader, so no point.+      -- Server is guaranteed to switch leader within a level occasionally,+      -- e.g., when the old leader dies, so this works fine.+      discouragedPointmanSwitchOnLevel =+        fskillsOther (gkind fact) == Ability.zeroSkills+  case oursNotSleeping of+    _ | -- Keep the leader: client is discouraged from leader switching,+        -- so it will only be changed if pointman waits (maidToAvoid)+        -- to avoid wasting his higher mobility.+        -- This is OK for monsters even if in melee, because both having+        -- a meleeing actor a leader (and higher DPS) and rescuing actor+        -- a leader (and so faster to get in melee range) is good.+        -- And we are guaranteed that only the two classes of actors are+        -- not waiting, with some exceptions (urgent unequip, flee via starts,+        -- melee-less trying to flee, first aid, etc.).+       discouragedPointmanSwitchOnLevel && isNothing maidToAvoid -> pickOld+    [] -> pickOld+    [(aidNotSleeping, bNotSleeping)] -> do+      -- Target of asleep actors won't change unless foe adjacent,+      -- which is caught without recourse to targeting.+      void $ refreshTarget foeAssocs friendAssocs (aidNotSleeping, bNotSleeping)+      return aidNotSleeping+    _ -> do+      -- At this point we almost forget who the old leader was+      -- and treat all party actors the same, eliminating candidates+      -- until we can't distinguish them any more, at which point we slightly+      -- prefer the old leader, if he is among the best candidates+      -- (to make the AI appear more human-like and easier to observe).+      let refresh aidBody = do+            mtgt <- refreshTarget foeAssocs friendAssocs aidBody+            return (aidBody, mtgt)+      oursTgtRaw <- mapM refresh oursNotSleeping+      oldFleeD <- getsClient sfleeD+      let recentlyFled aid = maybe False+                                   (\(_, time) -> timeRecent5 localTime time)+                                   (aid `EM.lookup` oldFleeD)+          goodGeneric (_, Nothing) = Nothing+          goodGeneric (_, Just TgtAndPath{tapPath=Nothing}) = Nothing+            -- this case means melee-less heroes adjacent to foes, etc.+            -- will never flee if melee is happening; but this is rare;+            -- this also ensures even if a lone actor melees and nobody+            -- can come to rescue, he will become and remain the leader,+            -- because otherwise an explorer would need to become a leader+            -- and fighter will be 1 clip slower for the whole fight,+            -- just for a few turns of exploration in return;+            --+            -- also note that when the fighter then becomes a leader+            -- he may gain quite a lot of time via @swapTime@,+            -- and so be able to get a double blow on opponents+            -- or a safe blow and a withdraw (but only once); this is a mild+            -- exploit that encourages ambush camping (with a non-leader),+            -- but it's also a rather fun exploit and a straightforward+            -- consequence of the game mechanics, so it's OK for now+          goodGeneric ((aid, b), Just tgt) = case maidToAvoid of+            _ | aid == oldAid && actorWaits b -> Nothing+                  -- Not the old leader that was stuck last turn+                  -- because he is likely to be still stuck.+            Nothing -> Just ((aid, b), tgt)+            Just aidToAvoid ->+              if aid == aidToAvoid+              then Nothing  -- not an attempted leader stuck this turn+              else Just ((aid, b), tgt)+          oursTgt = mapMaybe goodGeneric oursTgtRaw+          -- This should be kept in sync with @actionStrategy@,+          -- because it's a part of the condition for @flee@ in @PickActionM@.+          -- Comments are in the full copy.+          actorVulnerable ((aid, body), _) = do+            let actorMaxSk = actorMaxSkills EM.! aid+            condAnyHarmfulFoeAdj <-+              getsState $ anyHarmfulFoeAdj actorMaxSkills aid+            threatDistL <- getsState $ meleeThreatDistList foeAssocs aid+            (fleeL, _) <- fleeList foeAssocs aid+            condSupport1 <- condSupport friendAssocs 1 aid+            condSolo <- condAloneM friendAssocs aid+            let condCanFlee = not (null fleeL)+                heavilyDistressed =+                  deltasSerious (bcalmDelta body)+                speed1_5 = speedScale (3%2) (gearSpeed actorMaxSk)+                condCanMelee = actorCanMelee actorMaxSkills aid body+                threatAdj = takeWhile ((== 1) . fst) threatDistL+                condManyThreatAdj = length threatAdj >= 2+                condFastThreatAdj =+                  any (\(_, (aid2, _)) ->+                        let ar2 = actorMaxSkills EM.! aid2+                        in gearSpeed ar2 > speed1_5)+                      threatAdj+                condNonStealthyThreatAdj =+                  any (\(_, (aid2, b2)) ->+                        let ar2 = actorMaxSkills EM.! aid2+                        in Ability.getSk Ability.SkShine ar2 > 0+                           || isLit (bpos b2))+                      threatAdj+                isLit pos = Tile.isLit coTileSpeedup (lvl `at` pos)+                fleeingMakesSense =+                  not condCanMelee+                  || (Ability.getSk Ability.SkSight actorMaxSk > 2+                      || Ability.getSk Ability.SkNocto actorMaxSk > 2)+                     && (Ability.getSk Ability.SkShine actorMaxSk > 2+                         || condNonStealthyThreatAdj || null threatAdj)+            return $!+              not condFastThreatAdj+              && fleeingMakesSense+              && if | condAnyHarmfulFoeAdj ->+                      not condCanMelee+                      || condManyThreatAdj && not condSupport1 && not condSolo+                    | condInMelee -> False+                    | heavilyDistressed -> True+                        -- Different from @PickActionM@:+                        -- If under fire, do something quickly, always,+                        -- because the actor clearly vulnerable,+                        -- but don't make a leader only because threats close.+                    | otherwise -> False+              && condCanFlee+          actorFled ((aid, _), _) = recentlyFled aid+          actorHearning (_, TgtAndPath{ tapTgt=TPoint TEnemyPos{} _ _+                                      , tapPath=Nothing }) =+            return False+          actorHearning (_, TgtAndPath{ tapTgt=TPoint TEnemyPos{} _ _+                                      , tapPath=Just AndPath{pathLen} })+            | pathLen <= 2 =+            return False  -- noise probably due to fleeing target+          actorHearning ((_aid, b), _) = do+            let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos . snd)+                                   foeAssocs+                actorHears = deltasHears (bcalmDelta b)+            return $! actorHears  -- e.g., actor hears an enemy+                      && null closeFoes  -- the enemy not visible; a trap!+          -- AI has to be prudent and not lightly waste leader for meleeing.+          actorMeleeing ((aid, _), _) =+            getsState $ anyHarmfulFoeAdj actorMaxSkills aid+      (oursVulnerable, oursSafe) <- partitionM actorVulnerable oursTgt+      let (oursFled, oursNotFled) = partition actorFled oursSafe+      (oursMeleeingRaw, oursNotMeleeingRaw) <-+         partitionM actorMeleeing oursNotFled+      let actorMeleeingCanDisplace ( (aid, sb)+                                   , TgtAndPath{tapTgt=TEnemy target} ) = do+            tb <- getsState $ getActorBody target+            let actorMaxSk = actorMaxSkills EM.! target+            dEnemy <- getsState $ dispEnemy aid target actorMaxSk+            -- Some usual conditions ignored, because transient or rare.+            return $! checkAdjacent sb tb && dEnemy+          actorMeleeingCanDisplace _ = return False+      (oursMeleeingCanDisplace, oursMeleeing) <-+         partitionM actorMeleeingCanDisplace oursMeleeingRaw+      let adjStash+            ( (_, b)+            , TgtAndPath{tapTgt=TPoint TStash{} lid pos} ) =+                lid == arena+                && adjacent pos (bpos b)+                && isNothing (posToBigLvl pos lvl)+          adjStash _ = False+          (oursAdjStash, oursNotMeleeing) =+            partition adjStash oursNotMeleeingRaw+      (oursHearing, oursNotHearing) <- partitionM actorHearning oursNotMeleeing+      let actorRanged ((aid, body), _) =+            not $ actorCanMelee actorMaxSkills aid body+          targetTEnemy (_, TgtAndPath{tapTgt=TEnemy _}) = True+          targetTEnemy (_, TgtAndPath{tapTgt=TPoint TEnemyPos{} lid _}) =+            lid == arena+          targetTEnemy ((_, b), TgtAndPath{tapTgt=TPoint TStash{} lid pos}) =+            lid == arena && pos /= bpos b+              -- stashes as crucial as enemies. except when guarding them+          targetTEnemy _ = False+          actorNoSupport ((aid, _), _) = do+            threatDistL <- getsState $ meleeThreatDistList foeAssocs aid+            condSupport2 <- condSupport friendAssocs 2 aid+            let condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL+            -- If foes far, friends may still come, so we let him move.+            -- The net effect is that lone heroes close to foes freeze+            -- until support comes.+            return $! condThreat 5 && not condSupport2+          (oursRanged, oursNotRanged) = partition actorRanged oursNotHearing+          (oursTEnemyAll, oursOther) = partition targetTEnemy oursNotRanged+          notSwapReady ((_, b), TgtAndPath{tapTgt=TPoint TStash{} lid pos}) _ =+            lid == arena && pos == bpos b+              -- not ready to follow goal if already guarding the stash+          notSwapReady abt@((_, b), _)+                       (ab2, Just t2@TgtAndPath{tapPath=+                                       Just AndPath{pathList=q : _}}) =+            let source = bpos b+                tenemy = targetTEnemy abt+                tenemy2 = targetTEnemy (ab2, t2)+            -- Copied from 'displaceTowards':+            in not (q == source  -- friend wants to swap+                    || tenemy && not tenemy2)+          notSwapReady _ _ = True+          -- These are not necessarily stuck (perhaps can go around),+          -- but their current path is blocked by friends.+          -- As soon as friends move, path is recalcuated and they may+          -- become unstuck.+          targetBlocked abt@((aid, _), TgtAndPath{tapPath}) = case tapPath of+            Just AndPath{pathList= q : _} ->+              any (\abt2@((aid2, body2), _) ->+                     aid2 /= aid  -- in case pushed on goal+                     && bpos body2 == q+                     && notSwapReady abt abt2)+                  oursTgtRaw+            _ -> False+          (oursTEnemyBlocked, oursTEnemy) =+            partition targetBlocked oursTEnemyAll+      (oursNoSupportRaw, oursSupportRaw) <-+        if length oursTEnemy <= 2+        then return ([], oursTEnemy)+        else partitionM actorNoSupport oursTEnemy+      let (oursNoSupport, oursSupport) =+            if length oursSupportRaw <= 1  -- make sure picks random enough+            then ([], oursTEnemy)+            else (oursNoSupportRaw, oursSupportRaw)+          (oursBlocked, oursPos) =+            partition targetBlocked $ oursRanged ++ oursOther+          guarding ((_, b), Just TgtAndPath{tapTgt=TPoint TStash{} lid pos}) =+            lid == arena && pos == bpos b+          guarding _ = False+          -- Don't try to include a stash guard in formation, even if attacking+          -- or being attacked. Attackers would be targetted anyway.+          oursNotSleepingNorGuarding = filter (not . guarding) oursTgtRaw+          -- Lower overhead is better.+          overheadOurs :: ((ActorId, Actor), TgtAndPath) -> Int+          overheadOurs (_, TgtAndPath{tapPath=Nothing}) = 100+          overheadOurs ((_, b), TgtAndPath{tapTgt=TPoint TStash{} lid pos})+            | lid == arena && pos == bpos b = 200  -- guarding, poor choice+          overheadOurs abt@( (aid, b)+                           , TgtAndPath{tapPath=Just AndPath{pathLen=d, ..}} ) =+            -- Keep proper formation. Too dense and exploration takes+            -- too long; too sparse and actors fight alone.+            -- Note that right now, while we set targets separately for each+            -- hero, perhaps on opposite borders of the map,+            -- we can't help that sometimes heroes are separated.+            let maxSpread = 3 + length oursNotSleepingNorGuarding+                lDist p = [ chessDist (bpos b2) p+                          | ((aid2, b2), _) <- oursNotSleepingNorGuarding+                          , aid2 /= aid ]+                pDist p = let ld = lDist p+                          in if null ld then 0 else minimum ld+                aidDist = pDist (bpos b)+                -- Negative, if the goal gets us closer to the party.+                diffDist = pDist pathGoal - aidDist+                -- If actor already at goal or equidistant, count it as closer.+                sign = if diffDist <= 0 then -1 else 1+                formationValue =+                  sign * (abs diffDist `max` maxSpread)+                  * (aidDist `max` maxSpread) ^ (2 :: Int)+                targetsEnemy = targetTEnemy abt+                fightValue = if targetsEnemy+                             then - fromEnum (bhp b `div` (10 * oneM))+                             else 0+                isLit pos = Tile.isLit coTileSpeedup (lvl `at` pos)+                  -- solid tiles ignored, because not obvious if dark+                  -- after removed+                actorMaxSk = actorMaxSkills EM.! aid+                actorShines = Ability.getSk Ability.SkShine actorMaxSk > 0+                stepsIntoLight =+                  not actorShines+                  && not (isLit $ bpos b)+                  && case pathList of+                    [] -> False+                    q : _ -> isLit q+                      -- shortest path is through light even though may+                      -- sidestep through dark in @chase@ or @flee@+            in formationValue `div` 3+               + fightValue+               + (case d of+                    0 -> -400  -- do your thing ASAP and retarget+                    1 | not targetsEnemy -> -200+                      -- prevent others from trying to occupy the tile;+                      -- TStash that obscures a foe correctly handled here+                    _ -> if d < 8 then d `div` 4 else 2 + d `div` 10)+               + (if aid == oldAid then 0 else 10)+               + (if stepsIntoLight then 30 else 0)+          -- Overheads above @maxBoundInt32@ are unlikely (and unsuppored in JS)+          -- and also capping the value does not distort the choice too much.+          positiveOverhead abt =+            min maxBoundInt32 $ max 1 $ 200 - overheadOurs abt+          candidates = [ oursAdjStash+                       , oursVulnerable+                       , oursSupport+                       , oursNoSupport+                       , oursPos+                       , oursFled  -- if just fled, but not vulnerable,+                                   -- keep him passive and safe, out of action+                       , oursMeleeingCanDisplace+                           -- prefer melee actors displacing than blocked+                           -- actors trying to walk around them+                       , oursTEnemyBlocked+                           -- prefer blocked actors trying to walk around+                           -- even if that causes overhead for the meleeing+                       , oursMeleeing+                       , oursHearing+                       , oursBlocked+                       ]+      case filter (not . null) candidates of+        l : _ -> do+          let freq = toFreq "candidates for AI leader"+                     $ map (positiveOverhead &&& id) l+          ((aid, b), _) <- rndToAction $ frequency freq+          s <- getState+          modifyClient $ updateLeader aid s+          -- When you become a leader, stop following old leader, but follow+          -- his target, if still valid, to avoid distraction.+          when (gdoctrine fact `elem` [Ability.TFollow, Ability.TFollowNoItems]+                && not condInMelee) $+            void $ refreshTarget foeAssocs friendAssocs (aid, b)+          return aid+        _ -> return oldAid++-- | Inspect the doctrines of the actor and set his target according to it.+setTargetFromDoctrines :: MonadClient m+                        => [(ActorId, Actor)] -> [(ActorId, Actor)] -> ActorId+                        -> m ()+setTargetFromDoctrines foeAssocs friendAssocs oldAid = do+  mleader <- getsClient sleader+  let !_A = assert (mleader /= Just oldAid) ()+  oldBody <- getsState $ getActorBody oldAid+  moldTgt <- getsClient $ EM.lookup oldAid . stargetD+  let side = bfid oldBody+      arena = blid oldBody+  fact <- getsState $ (EM.! side) . sfactionD+  let explore = void $ refreshTarget foeAssocs friendAssocs (oldAid, oldBody)+      setPath mtgt = case (mtgt, moldTgt) of+        (Nothing, _) -> return False+        ( Just TgtAndPath{tapTgt=leaderTapTgt},+          Just TgtAndPath{tapTgt=oldTapTgt,tapPath=Just oldTapPath} )+          | leaderTapTgt == oldTapTgt  -- targets agree+            && bpos oldBody == pathSource oldTapPath -> do  -- nominal path+            void $ refreshTarget foeAssocs friendAssocs (oldAid, oldBody)+            return True  -- already on target+        (Just TgtAndPath{tapTgt=leaderTapTgt}, _) -> do+            tap <- createPath oldAid leaderTapTgt+            case tap of+              TgtAndPath{tapPath=Nothing} -> return False+              _ -> do+                modifyClient $ \cli ->+                  cli {stargetD = EM.insert oldAid tap (stargetD cli)}+                return True+      follow = case mleader of+        -- If no leader at all (forced @TFollow@ doctrine on an actor+        -- from a leaderless faction), fall back to @TExplore@.+        Nothing -> explore+        _ | bwatch oldBody == WSleep ->+          -- We could check skills, but it would be more complex.+          explore+        Just leader -> do+          onLevel <- getsState $ memActor leader arena+          condInMelee <- condInMeleeM arena+          -- If leader not on this level or if we are meleeing,+          -- and so following is not important, fall back to @TExplore@.+          if not onLevel || condInMelee then explore+          else do+            -- Copy over the leader's target, if any, or follow his position.+            mtgt <- getsClient $ EM.lookup leader . stargetD+            tgtPathSet <- setPath mtgt+            unless tgtPathSet $ do+              let nonEnemyPath = Just TgtAndPath { tapTgt = TNonEnemy leader+                                                 , tapPath = Nothing }+              nonEnemyPathSet <- setPath nonEnemyPath+              unless nonEnemyPathSet+                -- If no path even to the leader himself, explore.+                explore+  case gdoctrine fact of+    Ability.TExplore -> explore+    Ability.TFollow -> follow+    Ability.TFollowNoItems -> follow+    Ability.TMeleeAndRanged -> explore  -- needs to find ranged targets+    Ability.TMeleeAdjacent -> explore  -- probably not needed, but may change+    Ability.TBlock -> return ()  -- no point refreshing target+    Ability.TRoam -> explore  -- @TRoam@ is checked again inside @explore@+    Ability.TPatrol -> explore  -- WIP
+ engine-src/Game/LambdaHack/Client/AI/PickTargetM.hs view
@@ -0,0 +1,572 @@+{-# LANGUAGE TupleSections #-}+-- | Let AI pick the best target for an actor.+module Game.LambdaHack.Client.AI.PickTargetM+  ( refreshTarget+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , computeTarget+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import           Game.LambdaHack.Client.AI.ConditionM+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.CaveKind as CK+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (isUknownSpace)+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability++-- | Verify and possibly change the target of an actor. This function both+-- updates the target in the client state and returns the new target explicitly.+refreshTarget :: MonadClient m+              => [(ActorId, Actor)] -> [(ActorId, Actor)] -> (ActorId, Actor)+              -> m (Maybe TgtAndPath)+refreshTarget foeAssocs friendAssocs (aid, body) = do+  side <- getsClient sside+  let !_A = assert (bfid body == side+                    `blame` "AI tries to move an enemy actor"+                    `swith` (aid, body, side)) ()+  let !_A = assert (not (bproj body)+                    `blame` "AI gets to manually move its projectiles"+                    `swith` (aid, body, side)) ()+  mtarget <- computeTarget foeAssocs friendAssocs aid+  case mtarget of+    Nothing -> do+      -- Melee in progress and the actor can't contribute+      -- and would slow down others if he acted.+      -- Or he's just asleep.+      modifyClient $ \cli -> cli {stargetD = EM.delete aid (stargetD cli)}+      return Nothing+    Just tgtMPath -> do+      -- _debugoldTgt <- getsClient $ EM.lookup aid . stargetD+      modifyClient $ \cli ->+        cli {stargetD = EM.insert aid tgtMPath (stargetD cli)}+      return mtarget+      -- let _debug = T.unpack+      --       $ "\nHandleAI symbol:"    <+> tshow (bsymbol body)+      --       <> ", aid:"               <+> tshow aid+      --       <> ", pos:"               <+> tshow (bpos body)+      --       <> "\nHandleAI oldTgt:"   <+> tshow _debugoldTgt+      --       <> "\nHandleAI strTgt:"   <+> tshow stratTarget+      --       <> "\nHandleAI target:"   <+> tshow tgtMPath+      -- trace _debug $ return $ Just tgtMPath++computeTarget :: forall m. MonadClient m+              => [(ActorId, Actor)] -> [(ActorId, Actor)] -> ActorId+              -> m (Maybe TgtAndPath)+computeTarget foeAssocs friendAssocs aid = do+  cops@COps{cocave, corule=RuleContent{rWidthMax, rHeightMax, rnearby}, coTileSpeedup}+    <- getsState scops+  b <- getsState $ getActorBody aid+  mleader <- getsClient sleader+  salter <- getsClient salter+  -- We assume the actor eventually becomes a leader (or has the same+  -- set of skills as the leader, anyway) and set his target accordingly.+  actorMaxSkills <- getsState sactorMaxSkills+  condInMelee <- condInMeleeM $ blid b+  let lalter = salter EM.! blid b+      actorMaxSk = actorMaxSkills EM.! aid+      alterSkill = Ability.getSk Ability.SkAlter actorMaxSk+  lvl <- getLevel $ blid b+  localTime <- getsState $ getLocalTime (blid b)+  let stepAccesible :: [Point] -> Bool+      stepAccesible (q : _) =+        -- Effectively, only @alterMinWalk@ is checked, because real altering+        -- is not done via target path, but action after end of path.+        alterSkill >= fromEnum (lalter PointArray.! q)+      stepAccesible [] = False+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  oldTgtUpdatedPath <- case mtgtMPath of+    Just TgtAndPath{tapTgt,tapPath=Nothing} ->+      -- This case is especially for TEnemyPos that would be lost otherwise.+      -- This is also triggered by @UpdLeadFaction@.+      Just <$> createPath aid tapTgt+    Just tap@TgtAndPath{tapTgt,tapPath=Just AndPath{..}} -> do+      mvalidPos <- getsState $ aidTgtToPos (Just aid) (blid b) (Just tapTgt)+      return $!+        if | isNothing mvalidPos -> Nothing  -- wrong level+           | bpos b == pathGoal ->+               mtgtMPath  -- goal reached; stay there picking up items+                          -- or hiding in ambush or in panic+           | pathSource == bpos b ->  -- no move+               -- If next step not accessible, something serious happened,+               -- so reconsider the target, not only path.+               if stepAccesible pathList then mtgtMPath else Nothing+           | otherwise -> case break (== bpos b) pathList of+               (crossed, _ : rest) ->  -- step or many steps along path+                 if null rest+                 then Nothing  -- path to the goal was partial, so tiles+                               -- discovered or altered, so reconsider target+                 else let newPath =+                            AndPath{ pathSource = bpos b+                                   , pathList = rest+                                   , pathGoal+                                   , pathLen = pathLen - length crossed - 1 }+                      in if stepAccesible rest+                         then Just tap{tapPath=Just newPath}+                         else Nothing+               (_, []) -> Nothing  -- veered off the path, e.g., due to push+                                   -- by enemy or congestion, so serious,+                                   -- so reconsider target, not only path+    Nothing -> return Nothing  -- no target assigned yet+  factionD <- getsState sfactionD+  seps <- getsClient seps+  let fact = factionD EM.! bfid b+      slackDoctrine = gdoctrine fact+                      `elem` [ Ability.TMeleeAndRanged, Ability.TMeleeAdjacent+                             , Ability.TBlock, Ability.TRoam, Ability.TPatrol ]+      canMove = Ability.getSk Ability.SkMove actorMaxSk > 0+      canReach = canMove+                 || Ability.getSk Ability.SkDisplace actorMaxSk > 0+                 -- Needed for now, because AI targets and shoots enemies+                 -- based on the path to them, not LOS to them:+                 || Ability.getSk Ability.SkProject actorMaxSk > 0+      canAlter = Ability.getSk Ability.SkAlter actorMaxSk+                 >= if slackDoctrine then 2 else 4+      canMoveItem = Ability.getSk Ability.SkMoveItem actorMaxSk > 0+      calmE = calmEnough b actorMaxSk+      heavilyDistressed =  -- actor hit by a proj or similarly distressed+        deltasSerious (bcalmDelta b)+  -- Speedup compared to @currentSkillsClient@.+  actorMinSk <- getsState $ actorCurrentSkills Nothing aid+  condCanProject <-+    condCanProjectM (Ability.getSk Ability.SkProject actorMaxSk) aid+  fleeD <- getsClient sfleeD+  let condCanMelee = actorCanMelee actorMaxSkills aid b+      condHpTooLow = hpTooLow b actorMaxSk+      mfled = aid `EM.lookup` fleeD+      recentlyFled =+        maybe False (\(_, time) -> timeRecent5 localTime time) mfled+      recentlyFled20 =+        maybe False (\(_, time) -> timeRecent5 localTime time) mfled+      actorTurn = ticksPerMeter $ gearSpeed actorMaxSk+  let canEscape = fcanEscape (gkind fact)+      canSmell = Ability.getSk Ability.SkSmell actorMaxSk > 0+      meleeNearby | canEscape = rnearby `div` 2+                  | otherwise = rnearby+      rangedNearby = 2 * meleeNearby+      -- We do target foes that already attack ours or have benign weapons.+      -- We assume benign weapons run out if they are the sole cause+      -- of targeting, to avoid stalemate.+      worthTargeting aidE body =+        let attacksFriends =+              any (adjacent (bpos body) . bpos . snd) friendAssocs+              && actorCanMeleeToHarm actorMaxSkills aidE body+        in attacksFriends+           || bweapBenign body > 0+           || actorWorthChasing actorMaxSkills aidE body+      targetableMelee body =+        let attacksFriends =+              any (adjacent (bpos body) . bpos . snd) friendAssocs+            -- 3 is+            -- 1 from condSupport1+            -- + 2 from foe being 2 away from friend before he closed in+            -- + 1 for as a margin for ambush, given than actors exploring+            -- can't physically keep adjacent all the time+            n | Ability.getSk Ability.SkAggression actorMaxSk >= 2+              = rangedNearby+                  -- boss never waits+              | condInMelee = if attacksFriends then 8 else 4+                  -- attack even if foe not in melee, to create another+                  -- skirmish and perhaps overwhelm them in this one;+                  -- also, this looks more natural; also sometimes the foe+                  -- would attack our friend in a couple of turns anyway,+                  -- but we may be too far from him at that time+              | otherwise = meleeNearby+        in canMove+           && condCanMelee+           && chessDist (bpos body) (bpos b) <= n+      -- Even when missiles run out, the non-moving foe will still be+      -- targeted, which is fine, since he is weakened by ranged, so should be+      -- meleed ASAP, even if without friends.+      targetableRanged body =+        (not condInMelee || Ability.getSk Ability.SkAggression actorMaxSk >= 2)+          -- boss fires at will+        && chessDist (bpos body) (bpos b) < rangedNearby+        && condCanProject+        && (canMove || targetableLine body)+              -- prevent the exploit of using cover against non-moving shooters+              -- causing them to ignore any other distant foes+      targetableLine body = isJust $ makeLine False b (bpos body) seps cops lvl+      targetableEnemy (aidE, body) = worthTargeting aidE body+                                     && (adjacent (bpos body) (bpos b)+                                            -- target regardless of anything,+                                            -- e.g., to flee if helpless+                                         || targetableMelee body+                                         || targetableRanged body)+      targetableFoes = filter targetableEnemy foeAssocs+      canMeleeEnemy (aidE, body) = actorCanMeleeToHarm actorMaxSkills aidE body+      nearbyFoes = if recentlyFled && not condInMelee+                   then filter (not . canMeleeEnemy) targetableFoes+                   else targetableFoes+  discoBenefit <- getsClient sdiscoBenefit+  getKind <- getsState $ flip getIidKind+  getArItem <- getsState $ flip aspectRecordFromIid+  cstashes <- if canMove+                 && (calmE || null nearbyFoes) -- danger or risk of defecting+                 && not heavilyDistressed+                 && gunderAI fact  -- humans target any stashes explicitly+              then closestStashes aid+              else return []+  let desirableIid (iid, (k, _)) =+        let Benefit{benPickup} = discoBenefit EM.! iid+        in desirableItem cops canEscape benPickup+                         (getArItem iid) (getKind iid) k+      desirableBagFloor bag = any desirableIid $ EM.assocs bag+      desirableFloor (_, (_, bag)) = desirableBagFloor bag+      focused = gearSpeed actorMaxSk < speedWalk || condHpTooLow+      couldMoveLastTurn =  -- approximated; could have changed+        let actorSk = if mleader == Just aid then actorMaxSk else actorMinSk+        in Ability.getSk Ability.SkMove actorSk > 0+      isStuck = actorWaits b && couldMoveLastTurn+      setPath :: Target -> m (Maybe TgtAndPath)+      setPath tgt = do+        let take6 tap@TgtAndPath{tapTgt=TEnemy{}} = tap+              -- @TEnemy@ needed for projecting, even by roaming actors;+              -- however, CStash not as binding, so excursions possible+            take6 TgtAndPath{tapPath=Just AndPath{..}} =+              -- Path followed for up to 6 moves regardless if the target valid+              -- and then target forgot and a new one picked.+              let path6 = take 6 pathList+                  vOld = if bpos b /= pathGoal+                         then towards (bpos b) pathGoal+                         else Vector 0 0+                  tapTgt = TVector vOld+                  tapPath = Just AndPath{pathList=path6, ..}+              in TgtAndPath{..}+            take6 tap = tap+        tgtpath <- createPath aid tgt+        return $ Just $ if slackDoctrine then take6 tgtpath else tgtpath+      pickNewTarget = pickNewTargetIgnore Nothing+      pickNewTargetIgnore :: Maybe ActorId -> m (Maybe TgtAndPath)+      pickNewTargetIgnore maidToIgnore =+        case cstashes of+          (_, (fid2, pos2)) : _ -> setPath $ TPoint (TStash fid2) (blid b) pos2+          [] -> do+            let f aidToIgnore = filter ((/= aidToIgnore) . fst) nearbyFoes+                notIgnoredFoes = maybe nearbyFoes f maidToIgnore+            cfoes <- closestFoes notIgnoredFoes aid+            case cfoes of+             (_, (aid2, _)) : _ -> setPath $ TEnemy aid2+             [] | condInMelee -> return Nothing  -- don't slow down fighters+               -- this looks a bit strange, because teammates stop+               -- in their tracks all around the map (unless very close+               -- to the combatant), but the intuition is, not being able+               -- to help immediately, and not being too friendly+               -- to each other, they just wait and see and also shout+               -- to the teammate to flee and lure foes into ambush+             [] -> do+              mhideout <- if recentlyFled20+                          then closestHideout aid+                          else return Nothing+              case (mhideout, mfled) of+               (Just (p, dist), Just (_, time))+                 | timeDeltaToFrom localTime time+                   <= timeDeltaScale actorTurn (20 - dist) ->+                -- Only target if can reach the hideout 20 turns from fleeing+                -- start, given the actor speed as a leader.+                setPath $ TPoint THideout (blid b) p+               _ -> do+                citemsRaw <- if canMoveItem && canMove+                             then closestItems aid+                             else return []+                let citems = toFreq "closestItems"+                             $ filter desirableFloor citemsRaw+                if nullFreq citems then do+                  -- Tracking enemies is more important than exploring,+                  -- but smell is unreliable and may lead to allies,+                  -- not foes, so avoid it. However, let's keep smell+                  -- more imporant than getting to stairs, to let smelling+                  -- monsters follow cues even on explored levels.+                  smpos <- if canSmell+                           then closestSmell aid+                           else return []+                  case smpos of+                    [] -> do+                      ctriggersRaw <- closestTriggers ViaAnything aid+                      let ctriggers = toFreq "ctriggers" ctriggersRaw+                      if nullFreq ctriggers then do+                        let oldpos = fromMaybe (bpos b) (boldpos b)+                            vOld = bpos b `vectorToFrom` oldpos+                            pNew = shiftBounded rWidthMax rHeightMax (bpos b) vOld+                        if slackDoctrine && not isStuck && calmE && not focused+                           && isUnit vOld && bpos b /= pNew+                                -- both are needed, e.g., when just teleported+                                -- or when the shift bounded by level borders+                        then do+                          let vFreq = toFreq "vFreq"+                                      $ (20, vOld) : map (1,) moves+                          v <- rndToAction $ frequency vFreq+                          -- Once the most pressing targets exhaused,+                          -- wander around for 7 steps and only then,+                          -- or if blocked or derailed, consider again+                          -- the old and new targets.+                          --+                          -- Together with depending on heroes or aliens+                          -- to keep arean, sleepiness, inability to displace+                          -- and chasing random smells, this makes it very hard+                          -- to fully explore and change levels for, e.g.,+                          -- animals. Heroes idling on the level help a lot.+                          let pathSource = bpos b+                              traSlack7 = trajectoryToPathBounded+                                            rWidthMax rHeightMax pathSource+                                            (replicate 7 v)  -- > 6 from take6+                              pathList = map head $ group traSlack7+                              pathGoal = last pathList+                              pathLen = length pathList+                              tapTgt = TVector v+                              tapPath = Just AndPath{..}+                          return $ Just TgtAndPath {..}+                        else do+                          upos <- if canMove+                                  then closestUnknown aid+                                  else return Nothing+                          case upos of+                            Nothing -> do+                              -- If can't move (and so no BFS data),+                              -- no info gained. Or if can't open doors.+                              -- If stuck among ice pillars, we can't help it.+                              when (canMove && canAlter) $+                                modifyClient $ \cli -> cli {sexplored =+                                  ES.insert (blid b) (sexplored cli)}+                              ctriggersRaw2 <- closestTriggers ViaExit aid+                              let ctriggers2 = toFreq "ctriggers2" ctriggersRaw2+                              if nullFreq ctriggers2 then do+                                let toKill = actorWorthKilling actorMaxSkills+                                    worthyFoes = filter (uncurry toKill)+                                                        foeAssocs+                                afoes <- closestFoes worthyFoes aid+                                case afoes of+                                  (_, (aid2, _)) : _ ->+                                    -- All stones turned, time to win or die.+                                    setPath $ TEnemy aid2+                                  [] -> do+                                    furthest <- furthestKnown aid+                                    setPath $ TPoint TKnown (blid b) furthest+                              else do+                                (p, (p0, bag)) <-+                                  rndToAction $ frequency ctriggers2+                                setPath $ TPoint (TEmbed bag p0) (blid b) p+                            Just p -> setPath $ TPoint TUnknown (blid b) p+                      else do+                        (p, (p0, bag)) <- rndToAction $ frequency ctriggers+                        setPath $ TPoint (TEmbed bag p0) (blid b) p+                    (_, (p, _)) : _ -> setPath $ TPoint TSmell (blid b) p+                else do+                  (p, bag) <- rndToAction $ frequency citems+                  setPath $ TPoint (TItem bag) (blid b) p+      tellOthersNothingHere = do+        let f TgtAndPath{tapTgt} = case tapTgt of+              TPoint _ lid p -> p /= bpos b || lid /= blid b+              _ -> True+        modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)}+        pickNewTarget+      updateTgt :: TgtAndPath -> m (Maybe TgtAndPath)+      updateTgt TgtAndPath{tapPath=Nothing} = pickNewTarget+      updateTgt tap@TgtAndPath{tapPath=Just AndPath{..},tapTgt} = case tapTgt of+        TEnemy a -> do+          body <- getsState $ getActorBody a+          if   (condInMelee  -- fight close foes or nobody at all+                || bweapon body <= 0  -- not dangerous+                || not focused && not (null nearbyFoes))  -- prefers closer foes+               && a `notElem` map fst nearbyFoes  -- old one not close enough+               || blid body /= blid b  -- wrong level+               || actorDying body  -- foe already dying+               || not (worthTargeting a body)+               || recentlyFled+          then+                    -- forget enemy positions to prevent attacking them+                    -- again soon after flight+               pickNewTarget+          else do+               -- If there are no unwalkable tiles on the path to enemy,+               -- he gets target @TEnemy@ and then, even if such tiles emerge,+               -- the target updated by his moves remains @TEnemy@.+               -- Conversely, he is stuck with @TBlock@ if initial target had+               -- unwalkable tiles, for as long as they remain. Harmless quirk.+               mpath <- getCachePath aid $ bpos body+               case mpath of+                 Nothing -> pickNewTargetIgnore (Just a)+                   -- enemy became unreachable+                 Just AndPath{pathList=[]} -> pickNewTarget+                   -- he is his own enemy+                 Just AndPath{pathList= q : _} ->+                   -- If in melee and path blocked by actors (even proj.)+                   -- change target for this turn due to urgency.+                   -- Because of @condInMelee@ new target will be stash+                   -- or enemy if any other is left, or empty target.+                   -- If not in melee, keep target and consider your options+                   -- (wait until blocking actors move or displace or melee+                   -- or sidestep). We don't want to wander away+                   -- in search of loot, only to turn around next turn+                   -- when the enemy is again considered.+                   if not condInMelee+                      || q == bpos body  -- blocked by the enemy, great!+                      || not (occupiedBigLvl q lvl)+                         && not (occupiedProjLvl q lvl)+                   then return $ Just tap{tapPath=mpath}+                   else pickNewTargetIgnore (Just a)+        TPoint _ lid _ | lid /= blid b -> pickNewTarget  -- wrong level+        TPoint tgoal lid pos -> case tgoal of+          TStash fid2 -> do+            oursExploring <- getsState $ oursExploringAssocs (bfid b)+            let oursExploringLid =+                  filter (\(_, body) -> blid body == lid) oursExploring+                spawnFreqs = CK.cactorFreq $ okind cocave $ lkind lvl+                hasGroup grp = fromMaybe 0 (lookup grp spawnFreqs) > 0+                lvlSpawnsUs = any (hasGroup . fst) $ filter ((> 0) . snd)+                                                   $ fgroups (gkind fact)+           -- Even if made peace with the faction, loot stash one last time.+            if (calmE || null nearbyFoes)  -- no risk or can't defend anyway+               && not heavilyDistressed  -- not under heavy fire+               && gstash (factionD EM.! fid2) == Just (lid, pos)+               -- The condition below is more lenient than in @closestStashes@+               -- to avoid wasting time on guard's movement.+               && (fid2 == bfid b+                   && (pos == bpos b  -- guarded by me, so keep guarding+                       && (null nearbyFoes  -- if no foes nearby+                           || length oursExploringLid > 1) -- or buddies nearby+                       || isNothing (posToBigLvl pos lvl))  -- or unguarded+                   && (length oursExploring > 1  -- other actors able to explore+                       || lvlSpawnsUs)  -- or future spawned will be able+                   || isFoe (bfid b) fact fid2)+            then return $ Just tap+            else pickNewTarget+          -- In this case, need to retarget, to focus on foes that melee ours+          -- and not, e.g., on remembered foes or items.+          _ | condInMelee || not (null cstashes) -> pickNewTarget+          TEnemyPos _  -- chase last position even if foe hides+            | bpos b == pos -> tellOthersNothingHere+            | recentlyFled -> pickNewTarget+                -- forget enemy positions to prevent attacking them again soon+            | not (couldMoveLastTurn || null nearbyFoes) -> pickNewTarget+                -- if only, possibly, shooting, forget hotspots, target foes;+                -- this results in only pointman humans chasing old foes+                -- in preference of new visible ones, but it's fine+            | otherwise -> do+              -- Here pick the closer enemy, the remembered or seen, to avoid+              -- loops when approaching new enemy obscures him behind obstacle+              -- but reveals the previously remembered one, etc.+              let remainingDist = chessDist (bpos b) pos+              if any (\(_, b3) -> chessDist (bpos b) (bpos b3) < remainingDist)+                     nearbyFoes+              then pickNewTarget+              else return $ Just tap+          -- Don't stop fleeing into hideout after 5 turns even if foes appear.+          THideout ->+            -- Approach or stay in the hideout until 20 turns pass.+            if not recentlyFled20+            then pickNewTarget+            else return $ Just tap+          -- Prefer close foes to anything else below.+          _ | not (null nearbyFoes) -> pickNewTarget+          -- Below we check the target could not be picked again in+          -- pickNewTarget (e.g., an item got picked up by our teammate)+          -- and only in this case it is invalidated.+          -- This ensures targets are eventually reached (unless a foe+          -- shows up) and not changed all the time mid-route+          -- to equally interesting, but perhaps a bit closer targets,+          -- most probably already targeted by other actors.+          TEmbed bag p -> assert (adjacent pos p) $ do+            -- First, stairs and embedded items from @closestTriggers@.+            -- We don't check skills, because they normally don't change+            -- or we can put some equipment back and recover them.+            -- We don't determine if the stairs or embed are interesting+            -- (this changes with time), but allow the actor+            -- to reach them and then retarget. The two things we check+            -- is whether the embedded bag is still there, or used up+            -- and whether we happen to be already adjacent to @p@,+            -- even though not necessarily at @pos@.+            bag2 <- getsState $ getEmbedBag lid p  -- not @pos@+            if | bag /= bag2 -> pickNewTarget  -- others will notice soon enough+               | adjacent (bpos b) p ->  -- regardless if at @pos@ or not+                   setPath $ TPoint TKnown lid (bpos b)+                     -- stay there one turn (high chance to become leader)+                     -- to enable triggering; if trigger fails+                     -- (e.g, changed skills), will retarget next turn (@TAny@)+               | otherwise -> return $ Just tap+          TItem bag -> do+            bag2 <- getsState $ getFloorBag lid pos+            if | bag /= bag2 -> pickNewTarget  -- others will notice soon enough+               | bpos b == pos ->+                   setPath $ TPoint TKnown lid (bpos b)+                     -- stay there one turn (high chance to become leader)+                     -- to enable pickup; if pickup fails, will retarget+               | otherwise -> return $ Just tap+          TSmell ->+            if not canSmell+               || let sml = EM.findWithDefault timeZero pos (lsmell lvl)+                  in sml <= ltime lvl+            then pickNewTarget  -- others will notice soon enough+            else return $ Just tap+          TBlock -> do  -- e.g., door or first unknown tile of an area+            let t = lvl `at` pos+            if isStuck  -- not a very important target, because blocked+               || alterSkill < fromEnum (lalter PointArray.! pos)+                    -- tile was searched or altered or skill lowered+               || Tile.isWalkable coTileSpeedup t+                    -- tile is no longer unwalkable, so was explored+                    -- so time to recalculate target+            then pickNewTarget  -- others will notice soon enough+            else return $ Just tap+          TUnknown ->+            let t = lvl `at` pos+            in if lexpl lvl <= lseen lvl+                  || not (isUknownSpace t)+               then pickNewTarget  -- others will notice soon enough+               else return $ Just tap+          TKnown ->+            if bpos b == pos+               || isStuck+               || alterSkill < fromEnum (lalter PointArray.! pos)+                    -- tile was searched or altered or skill lowered+            then pickNewTarget  -- others unconcerned+            else return $ Just tap+        _ | condInMelee || not (null nearbyFoes && null cstashes) ->+            pickNewTarget+        TNonEnemy _ | mleader == Just aid ->  -- a leader, never follow+          pickNewTarget+        TNonEnemy a -> do+          body <- getsState $ getActorBody a+          if blid body /= blid b  -- wrong level+          then pickNewTarget+          else do+            -- Update path. If impossible, pick another target.+            mpath <- getCachePath aid $ bpos body+            case mpath of+              Nothing -> pickNewTarget+              Just AndPath{pathList=[]} -> pickNewTarget+              _ -> return $ Just tap{tapPath=mpath}+        TVector{} -> if bpos b /= pathGoal+                     then return $ Just tap+                     else pickNewTarget+  if canReach+  then maybe pickNewTarget updateTgt oldTgtUpdatedPath+  else return Nothing
+ engine-src/Game/LambdaHack/Client/AI/Strategy.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE DeriveTraversable, TupleSections #-}+-- | AI strategies to direct actors not controlled directly by human players.+-- No operation in this module involves the @State@ type or any of our+-- client/server monads types.+module Game.LambdaHack.Client.AI.Strategy+  ( Strategy, nullStrategy, liftFrequency+  , (.|), reject, (.=>), only, bestVariant, returN, mapStrategyM+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Control.Applicative++import Game.LambdaHack.Core.Frequency++-- | A strategy is a choice of (non-empty) frequency tables+-- of possible actions.+--+-- Currently, the way we use it, the list could have at most one element+-- (we filter out void frequencies early and only ever access the first).+-- except for the argument of @mapStrategyM@, which may even be process+-- to the end of the list, if no earlier strategies can be transformed+-- into non-null ones.+newtype Strategy a = Strategy { runStrategy :: [Frequency a] }+  deriving (Show, Foldable, Traversable)++instance Monad Strategy where+  m >>= f  = normalizeStrategy $ Strategy+    [ toFreq name [+#ifdef WITH_EXPENSIVE_ASSERTIONS+                    assert (toInteger p * toInteger q+                            <= toInteger maxBoundInt32)+#endif+                    (p * q, b)+                  | (p, a) <- runFrequency x+                  , y <- runStrategy (f a)+                  , (q, b) <- runFrequency y+                  ]+    | x <- runStrategy m+    , let name = "Strategy_bind (" <> nameFrequency x <> ")"]++instance Functor Strategy where+  fmap f (Strategy fs) = Strategy (map (fmap f) fs)++instance Applicative Strategy where+  {-# INLINE pure #-}+  pure x = Strategy $ return $! uniformFreq "Strategy_pure" [x]+  (<*>) = ap++instance MonadPlus Strategy where+  mzero = Strategy []+  mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)++instance Alternative Strategy where+  (<|>) = mplus+  empty = mzero++normalizeStrategy :: Strategy a -> Strategy a+normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs++nullStrategy :: Strategy a -> Bool+nullStrategy strat = null $ runStrategy strat++-- | Strategy where only the actions from the given single frequency table+-- can be picked.+liftFrequency :: Frequency a -> Strategy a+liftFrequency f = normalizeStrategy $ Strategy $ return f++infixr 2 .|++-- | Strategy with the actions from both argument strategies,+-- with original frequencies.+(.|) :: Strategy a -> Strategy a -> Strategy a+(.|) = mplus++-- | Strategy with no actions at all.+reject :: Strategy a+reject = mzero++infix 3 .=>++-- | Conditionally accepted strategy.+(.=>) :: Bool -> Strategy a -> Strategy a+p .=> m | p         = m+        | otherwise = mzero++-- | Strategy with all actions not satisfying the predicate removed.+-- The remaining actions keep their original relative frequency values.+only :: (a -> Bool) -> Strategy a -> Strategy a+only p s = normalizeStrategy $ do+  x <- s+  p x .=> return x++-- | When better choices are towards the start of the list,+-- this is the best frequency of the strategy.+bestVariant :: Strategy a -> Frequency a+bestVariant (Strategy []) = mzero+bestVariant (Strategy (f : _)) = f++-- | Like 'return', but pick a name of the single frequency.+returN :: Text -> a -> Strategy a+returN name x = Strategy $ return $! uniformFreq name [x]++mapStrategyM :: Monad m => (a -> m (Maybe b)) -> Strategy a -> m (Strategy b)+mapStrategyM f s = do+  let mapFreq freq = do+        let g (k, a) = do+              mb <- f a+              return $! (k,) <$> mb+        lbm <- mapM g $ runFrequency freq+        return $! toFreq "mapStrategyM" $ catMaybes lbm+      ls = runStrategy s+  lt <- mapM mapFreq ls+  return $! normalizeStrategy $ Strategy lt
+ engine-src/Game/LambdaHack/Client/Bfs.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, RankNTypes,+             TypeFamilies #-}+-- | Breadth first search algorithm.+module Game.LambdaHack.Client.Bfs+  ( BfsDistance, MoveLegal(..)+  , subtractBfsDistance, minKnownBfs, apartBfs, maxBfsDistance, fillBfs+  , AndPath(..), findPathBfs, accessBfs+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , succBfsDistance, predBfsDistance, abortedUnknownBfs, maskBfs, distanceBfs+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Monad.ST.Strict (ST, runST)+import           Data.Binary+import           Data.Bits (Bits, complement, (.&.), (.|.))+import qualified Data.EnumSet as ES+import qualified Data.IntSet as IS+import qualified Data.Primitive.PrimArray as PA+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import           GHC.Exts (inline)+import           GHC.Generics (Generic)++import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Definition.Defs++-- @Word8@ is much faster, but in some very rare cases leads to AI loops,+-- e.g., when a move through uknown terrain towards enemy stash+-- goes beyond the @apartBfs@ range and makes AI abandon the stash target,+-- only to pick it up after a step in the opposite direction.+-- In normal LH maps, path length can get to around 200,+-- in contrived mazes it could perhaps reach a few thousand.+type DistanceWord = Word16++-- | Weighted distance between points along shortest paths.+newtype BfsDistance = BfsDistance {bfsDistance :: DistanceWord}+  deriving (Show, Eq, Ord, Bits)++instance PointArray.UnboxRepClass BfsDistance where+  type UnboxRep BfsDistance = DistanceWord+  toUnboxRepUnsafe = bfsDistance+  fromUnboxRep = BfsDistance++-- | State of legality of moves between adjacent points.+data MoveLegal = MoveBlocked | MoveToOpen | MoveToClosed | MoveToUnknown+  deriving Eq++succBfsDistance :: BfsDistance -> BfsDistance+succBfsDistance d = BfsDistance $ bfsDistance d + 1++predBfsDistance :: BfsDistance -> BfsDistance+predBfsDistance d = BfsDistance $ bfsDistance d - 1++subtractBfsDistance :: BfsDistance -> BfsDistance -> Int+subtractBfsDistance d1 d2 = fromEnum $ bfsDistance d1 - bfsDistance d2++-- | The minimal distance value assigned to paths that don't enter+-- any unknown tiles.+minKnownBfs :: BfsDistance+minKnownBfs = BfsDistance $ 1 + maxBound `div` 2++-- | The distance value that denotes no legal path between points,+-- either due to blocked tiles or pathfinding aborted at earlier tiles,+-- e.g., due to unknown tiles.+apartBfs :: BfsDistance+apartBfs = predBfsDistance minKnownBfs++-- | Maximum value of the type.+maxBfsDistance :: BfsDistance+maxBfsDistance = BfsDistance (maxBound :: DistanceWord)++-- | The distance value that denotes that path search was aborted+-- at this tile due to too large actual distance+-- and that the tile was unknown.+-- It is also a true distance value for this tile.+abortedUnknownBfs :: BfsDistance+abortedUnknownBfs = predBfsDistance apartBfs++maskBfs :: BfsDistance -> BfsDistance+{-# INLINE maskBfs #-}+maskBfs distance = distance .&. complement minKnownBfs++-- | Create and fill a BFS array for the given level.+-- Unsafe array operations are OK here, because the intermediate+-- values of the vector don't leak anywhere outside nor are kept unevaluated+-- and so they can't be overwritten by the unsafe side-effect.+--+-- When computing move cost, we assume doors openable at no cost,+-- because other actors use them, too, so the cost is shared and the extra+-- visiblity is valuable, too. We treat unknown tiles specially.+-- Whether suspect tiles are considered openable depends on @smarkSuspect@.+--+-- Instead of a BFS queue (list) we use the two tabs (arrays), for (JS) speed.+fillBfs :: PointArray.Array Word8+        -> Word8+        -> Point+        -> (PA.PrimArray PointI, PA.PrimArray PointI)+        -> PointArray.Array BfsDistance+fillBfs !lalter !alterSkill !source (!tabA, !tabB) = runST $ do+  let arr = PointArray.replicateA+              (PointArray.axsize lalter) (PointArray.aysize lalter) apartBfs+  vThawed <- U.unsafeThaw $ PointArray.avector arr+  tabAThawed <- PA.unsafeThawPrimArray tabA+  tabBThawed <- PA.unsafeThawPrimArray tabB+  fillBfsThawed lalter alterSkill (fromEnum source)+                (tabAThawed, tabBThawed) vThawed+  void $ PA.unsafeFreezePrimArray tabAThawed+  void $ PA.unsafeFreezePrimArray tabBThawed+  void $ U.unsafeFreeze vThawed+  return arr++type QueueIx = Int++type NextQueueIx = Int++-- So very low-level that not even under EXPOSE_INTERNAL.+fillBfsThawed :: forall s.+                 PointArray.Array Word8+              -> Word8+              -> PointI+              -> (PA.MutablePrimArray s PointI, PA.MutablePrimArray s PointI)+              -> U.MVector s DistanceWord+              -> ST s ()+fillBfsThawed !lalter !alterSkill !sourceI+              (!tabAThawed, !tabBThawed) !vThawed = do+  let unsafeReadI :: PointI -> ST s BfsDistance+      {-# INLINE unsafeReadI #-}+#ifdef WITH_EXPENSIVE_ASSERTIONS+      unsafeReadI p = BfsDistance <$> VM.read vThawed p+        -- index checking is sometimes an expensive (kind of) assertion+#else+      unsafeReadI p = BfsDistance <$> VM.unsafeRead vThawed p+#endif+      unsafeWriteI :: PointI -> BfsDistance -> ST s ()+      {-# INLINE unsafeWriteI #-}+#ifdef WITH_EXPENSIVE_ASSERTIONS+      unsafeWriteI p c = VM.write vThawed p (bfsDistance c)+#else+      unsafeWriteI p c = VM.unsafeWrite vThawed p (bfsDistance c)+#endif+      -- The two tabs (arrays) are used as a staged, optimized queue.+      -- The first tab is for writes, the second one for reads.+      -- They switch places in each recursive @bfs@ call.+      bfs :: PA.MutablePrimArray s PointI+          -> PA.MutablePrimArray s PointI+          -> BfsDistance+          -> QueueIx+          -> ST s ()+      bfs !tabReadThawed !tabWriteThawed !distance !prevQueueIx = do+        let unsafeReadCurrent :: QueueIx -> ST s PointI+            {-# INLINE unsafeReadCurrent #-}+            unsafeReadCurrent = PA.readPrimArray tabReadThawed+            unsafeWriteNext :: QueueIx -> PointI -> ST s ()+            {-# INLINE unsafeWriteNext #-}+            unsafeWriteNext = PA.writePrimArray tabWriteThawed+            -- The accumulator and the result represent the index into the next+            -- queue tab, incremented after each write.+            processQueue :: QueueIx -> NextQueueIx -> ST s NextQueueIx+            processQueue !currentQueueIx !acc1 =+              if currentQueueIx == -1+              then return acc1  -- all queued positions inspected+              else do+                pos <- unsafeReadCurrent currentQueueIx+                let processMove :: (X, Y) -> NextQueueIx -> ST s NextQueueIx+                    {-# INLINE processMove #-}+                    processMove move acc2 = do+                      let p = pos + inline fromEnum (uncurry Vector move)+                      pDist <- unsafeReadI p+                      if pDist /= apartBfs+                      then return acc2  -- the position visited already+                      else do+                        let alter :: Word8+                            !alter = lalter `PointArray.accessI` p+                        if | alterSkill < alter -> return acc2+                           | alter == 1 -> do+                             let distCompl = maskBfs distance+                             unsafeWriteI p distCompl+                             return acc2+                           | otherwise -> do+                             unsafeWriteI p distance+                             unsafeWriteNext acc2 p+                             return $! acc2 + 1+                -- Innermost loop over @moves@ manually unrolled for (JS) speed:+                return acc1+                  >>= processMove (-1, -1)+                  >>= processMove (0, -1)+                  >>= processMove (1, -1)+                  >>= processMove (1, 0)+                  >>= processMove (1, 1)+                  >>= processMove (0, 1)+                  >>= processMove (-1, 1)+                  >>= processMove (-1, 0)+                  -- Recursive call to process next queue element:+                  >>= processQueue (currentQueueIx - 1)+        acc3 <- processQueue (prevQueueIx - 1) 0+        let distanceNew = succBfsDistance distance+        if acc3 == 0 || distanceNew == maxBfsDistance+        then return () -- no more close enough dungeon positions+        else bfs tabWriteThawed tabReadThawed distanceNew acc3+#ifdef WITH_EXPENSIVE_ASSERTIONS+  VM.write vThawed sourceI (bfsDistance minKnownBfs)+#else+  VM.unsafeWrite vThawed sourceI (bfsDistance minKnownBfs)+#endif+  PA.writePrimArray tabAThawed 0 sourceI+  bfs tabAThawed tabBThawed (succBfsDistance minKnownBfs) 1++data AndPath = AndPath+  { pathSource :: Point    -- never included in @pathList@+  , pathList   :: [Point]+  , pathGoal   :: Point    -- needn't be @last pathList@+  , pathLen    :: Int      -- needn't be @length pathList@+  }+  deriving (Show, Generic)++instance Binary AndPath++-- | Find a path, without the source position, with the smallest length.+-- The @eps@ coefficient determines which direction (of the closest+-- directions available) that path should prefer, where 0 means north-west+-- and 1 means north. The path tries hard to avoid actors and tries to avoid+-- tiles that need altering and ambient light. Actors are avoided only close+-- to the start of the path, because elsewhere they are likely to move+-- before they are reached. Even projectiles are avoided,+-- which sometimes has the effect of choosing a safer route+-- (regardless if the projectiles are friendly fire or not).+--+-- An unwelcome side effect of avoiding actors is that friends will sometimes+-- avoid displacing and instead perform two separate moves, wasting 1 turn+-- in total (only if they had opposed direction of their goals; unlikely).+-- But in corridors they will still displace and elsewhere this scenario+-- was quite rare already.+findPathBfs :: ES.EnumSet Point -> PointArray.Array Word8 -> (PointI -> Bool)+            -> Point -> Point -> Int+            -> PointArray.Array BfsDistance+            -> Maybe AndPath+{-# INLINE findPathBfs #-}+findPathBfs lbig lalter fovLit pathSource pathGoal sepsRaw arr =+  let !pathGoalI = fromEnum pathGoal+      !pathSourceI = fromEnum pathSource+      eps = sepsRaw `mod` 4+      (mc1, mc2) = splitAt eps movesCardinalI+      (md1, md2) = splitAt eps movesDiagonalI+      -- Prefer cardinal directions when closer to the target, so that+      -- the enemy can't easily disengage.+      prefMoves = mc2 ++ reverse mc1 ++ md2 ++ reverse md1  -- fuzz+      track :: PointI -> BfsDistance -> [Point] -> [Point]+      track !pos !oldDist !suffix | oldDist == minKnownBfs =+        assert (pos == pathSourceI) suffix+      track pos oldDist suffix | oldDist == succBfsDistance minKnownBfs =+        let !posP = toEnum pos+        in posP : suffix  -- avoid calculating minP and dist for the last call+      track pos oldDist suffix =+        let !dist = predBfsDistance oldDist+            minChild :: PointI -> Bool -> Word8 -> [VectorI] -> PointI+            minChild !minP _ _ [] = minP+            minChild minP maxDark minAlter (mv : mvs) =+              let !p = pos + mv+                  backtrackingMove =+                    BfsDistance (arr `PointArray.accessI` p) /= dist+              in if backtrackingMove+                 then minChild minP maxDark minAlter mvs+                 else let free = p `IS.notMember` ES.enumSetToIntSet lbig+                          alter | free = lalter `PointArray.accessI` p+                                | otherwise = maxBound-1  -- occupied; disaster+                          dark = not $ fovLit p+                      -- Prefer paths without actors and through+                      -- more easily opened tiles and, secondly,+                      -- in the ambient dark (even if light carried,+                      -- because it can be taken off at any moment).+                      in if | alter == 0 && dark -> p  -- speedup+                            | alter < minAlter -> minChild p dark alter mvs+                            | dark > maxDark && alter == minAlter ->+                              minChild p dark alter mvs+                            | otherwise -> minChild minP maxDark minAlter mvs+            -- @maxBound@ means not alterable, so some child will be lower+            !newPos = minChild pos{-dummy-} False maxBound prefMoves+#ifdef WITH_EXPENSIVE_ASSERTIONS+            !_A = assert (newPos /= pos) ()+#endif+            !posP = toEnum pos+        in track newPos dist (posP : suffix)+      !goalDist = BfsDistance $ arr `PointArray.accessI` pathGoalI+      pathLen = fromEnum $ bfsDistance $ maskBfs goalDist+      pathList = track pathGoalI (goalDist .|. minKnownBfs) []+      andPath = AndPath{..}+  in assert (BfsDistance (arr `PointArray.accessI` pathSourceI)+             == minKnownBfs) $+     if goalDist /= apartBfs && pathLen < 2 * chessDist pathSource pathGoal+     then Just andPath+     else let f :: (Point, Int, Int, Int) -> Point -> BfsDistance+                -> (Point, Int, Int, Int)+              f acc@(pAcc, dAcc, chessAcc, sumAcc) p d =+                if d <= abortedUnknownBfs  -- works in visible secrets mode only+                   || d /= apartBfs && adjacent p pathGoal  -- works for stairs+                then let dist = fromEnum $ bfsDistance $ maskBfs d+                         chessNew = chessDist p pathGoal+                         sumNew = dist + 2 * chessNew+                         resNew = (p, dist, chessNew, sumNew)+                     in case compare sumNew sumAcc of+                       LT -> resNew+                       EQ -> case compare chessNew chessAcc of+                         LT -> resNew+                         EQ -> case compare dist dAcc of+                           LT -> resNew+                           EQ | euclidDistSq p pathGoal+                                < euclidDistSq pAcc pathGoal -> resNew+                           _ -> acc+                         _ -> acc+                       _ -> acc+                else acc+              initAcc = (originPoint, maxBound, maxBound, maxBound)+              (pRes, dRes, _, sumRes) = PointArray.ifoldlA' f initAcc arr+          in if sumRes == maxBound+                || goalDist /= apartBfs && pathLen < sumRes+             then if goalDist /= apartBfs then Just andPath else Nothing+             else let pathList2 =+                        track (fromEnum pRes)+                              (BfsDistance (toEnum dRes) .|. minKnownBfs) []+                  in Just AndPath{pathList = pathList2, pathLen = sumRes, ..}++-- | Access a BFS array and interpret the looked up distance value.+accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int+accessBfs bfs p = if PointArray.axsize bfs == 0+                  then Nothing+                  else distanceBfs $ bfs PointArray.! p++distanceBfs :: BfsDistance -> Maybe Int+{-# INLINE distanceBfs #-}+distanceBfs dist = if dist == apartBfs+                   then Nothing+                   else Just $ fromEnum $ bfsDistance $ maskBfs dist
+ engine-src/Game/LambdaHack/Client/BfsM.hs view
@@ -0,0 +1,628 @@+{-# LANGUAGE TupleSections #-}+-- | Breadth first search and related algorithms using the client monad.+module Game.LambdaHack.Client.BfsM+  ( invalidateBfsAid, invalidateBfsPathAid+  , invalidateBfsLid, invalidateBfsPathLid+  , invalidateBfsAll, invalidateBfsPathAll+  , createBfs, getCacheBfsAndPath, getCacheBfs+  , getCachePath, createPath, condBFS+  , furthestKnown, closestUnknown, closestSmell+  , FleeViaStairsOrEscape(..)+  , embedBenefit, closestTriggers, condEnoughGearM, closestItems, closestFoes+  , closestStashes, oursExploringAssocs, closestHideout+#ifdef EXPOSE_INTERNAL+  , unexploredDepth, updatePathFromBfs+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Word++import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.CaveKind as CK+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (isUknownSpace)+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++invalidateBfsAid :: MonadClient m => ActorId -> m ()+invalidateBfsAid aid =+  modifyClient $ \cli ->+    cli {sbfsD = EM.adjust (const BfsInvalid) aid (sbfsD cli)}++invalidateBfsPathAid :: MonadClient m => ActorId -> m ()+invalidateBfsPathAid aid = do+  let f BfsInvalid = BfsInvalid+      f (BfsAndPath bfsArr _) = BfsAndPath bfsArr EM.empty+  modifyClient $ \cli -> cli {sbfsD = EM.adjust f aid (sbfsD cli)}++-- Even very distant actors affected, e.g., when a hidden door found in a wall.+invalidateBfsLid :: MonadClient m => LevelId -> m ()+invalidateBfsLid lid = do+  lvl <- getLevel lid+  -- No need to filter, because foes won't be in our BFS map and looking up+  -- in our BFS map is faster than in all actors map.+  mapM_ invalidateBfsAid $ EM.elems $ lbig lvl++-- We invalidate, but not when actors move, since they are likely to move+-- out of the way in time. We only do, when they appear or disappear,+-- because they may be immobile or too close to move away before we get there.+-- We also don't consider far actors, since they are likely to disappear+-- again or to be far from our path. If they close enough to be lit+-- by our light, or one step further, that's worth taking seriously.+invalidateBfsPathLid :: MonadClient m => Actor -> m ()+invalidateBfsPathLid body = do+  lvl <- getLevel $ blid body+  let close (p, _) = chessDist p (bpos body) <= 3  -- heuristic+  -- No need to filter more, because foes won't be in our BFS map and looking up+  -- in our BFS map is faster than in all actors map.+  mapM_ (invalidateBfsPathAid . snd) $ filter close $ EM.assocs $ lbig lvl++invalidateBfsAll :: MonadClient m => m ()+invalidateBfsAll =+  modifyClient $ \cli -> cli {sbfsD = EM.map (const BfsInvalid) (sbfsD cli)}++invalidateBfsPathAll :: MonadClient m => m ()+invalidateBfsPathAll = do+  let f BfsInvalid = BfsInvalid+      f (BfsAndPath bfsArr _) = BfsAndPath bfsArr EM.empty+  modifyClient $ \cli -> cli {sbfsD = EM.map f (sbfsD cli)}++createBfs :: MonadClientRead m+          => Bool -> Word8 -> ActorId -> m (PointArray.Array BfsDistance)+createBfs canMove alterSkill0 aid =+  if canMove then do+    b <- getsState $ getActorBody aid+    salter <- getsClient salter+    let source = bpos b+        lalter = salter EM.! blid b+        alterSkill = max 1 alterSkill0+          -- We increase 0 skill to 1, to also path through unknown tiles.+          -- Since there are no other tiles that require skill 1, this is safe.+    stabs <- getsClient stabs+    return $! fillBfs lalter alterSkill source stabs+  else return PointArray.empty++updatePathFromBfs :: MonadClient m+                  => Bool -> BfsAndPath -> ActorId -> Point+                  -> m (PointArray.Array BfsDistance, Maybe AndPath)+updatePathFromBfs canMove bfsAndPathOld aid !target = do+  COps{coTileSpeedup} <- getsState scops+  let (oldBfsArr, oldBfsPath) = case bfsAndPathOld of+        (BfsAndPath bfsArr bfsPath) -> (bfsArr, bfsPath)+        BfsInvalid -> error $ "" `showFailure` (bfsAndPathOld, aid, target)+  let bfsArr = oldBfsArr+  if not canMove+  then return (bfsArr, Nothing)+  else do+    getActorB <- getsState $ flip getActorBody+    let b = getActorB aid+    fact <- getsState $ (EM.! bfid b) . sfactionD+    seps <- getsClient seps+    salter <- getsClient salter+    lvl <- getLevel (blid b)+    let !lalter = salter EM.! blid b+        fovLit p = Tile.isLit coTileSpeedup $ PointArray.fromUnboxRep+                                            $ ltile lvl `PointArray.accessI` p+        addFoeVicinity (p, aid2) =+          let b2 = getActorB aid2+          in if isFoe (bfid b) fact (bfid b2)+             then p : vicinityUnsafe p+             else [p]+        bigAdj = ES.fromList $ concatMap addFoeVicinity $ EM.assocs+                 $ EM.delete source $ lbig lvl  -- don't sidestep oneself+        !source = bpos b+        !mpath = findPathBfs bigAdj lalter fovLit source target seps bfsArr+        !bfsPath =+          maybe oldBfsPath (\path -> EM.insert target path oldBfsPath) mpath+        bap = BfsAndPath bfsArr bfsPath+    modifyClient $ \cli -> cli {sbfsD = EM.insert aid bap $ sbfsD cli}+    return (bfsArr, mpath)++-- | Get cached BFS array and path or, if not stored, generate and store first.+getCacheBfsAndPath :: forall m. MonadClient m+                   => ActorId -> Point+                   -> m (PointArray.Array BfsDistance, Maybe AndPath)+getCacheBfsAndPath aid target = do+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just bap@(BfsAndPath bfsArr bfsPath) ->+      case EM.lookup target bfsPath of+        Nothing -> do+          (!canMove, _) <- condBFS aid+          updatePathFromBfs canMove bap aid target+        mpath@Just{} -> return (bfsArr, mpath)+    _ -> do+      (canMove, alterSkill) <- condBFS aid+      !bfsArr <- createBfs canMove alterSkill aid+      let bfsPath = EM.empty+      updatePathFromBfs canMove (BfsAndPath bfsArr bfsPath) aid target++-- | Get cached BFS array or, if not stored, generate and store first.+getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)+getCacheBfs aid = do+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just (BfsAndPath bfsArr _) -> return bfsArr+    _ -> do+      (canMove, alterSkill) <- condBFS aid+      !bfsArr <- createBfs canMove alterSkill aid+      let bfsPath = EM.empty+      modifyClient $ \cli ->+        cli {sbfsD = EM.insert aid (BfsAndPath bfsArr bfsPath) (sbfsD cli)}+      return bfsArr++-- | Get cached BFS path or, if not stored, generate and store first.+getCachePath :: MonadClient m => ActorId -> Point -> m (Maybe AndPath)+getCachePath aid target = do+  b <- getsState $ getActorBody aid+  let source = bpos b+  if source == target+  then return $ Just $ AndPath (bpos b) [] target 0  -- speedup+  else snd <$> getCacheBfsAndPath aid target++createPath :: MonadClient m => ActorId -> Target -> m TgtAndPath+createPath aid tapTgt = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let stopAtUnwalkable tapPath@(Just AndPath{..}) =+        let (walkable, rest) =+              -- Unknown tiles are not walkable, so path stops just before.+              -- which is good, because by the time actor reaches the tile,+              -- it is known and target is recalculated with new info,+              -- perhaps sidestepping the tile, e.g., if explosive.+              span (Tile.isWalkable coTileSpeedup . at lvl) pathList+        in case rest of+          _ | null walkable -> TgtAndPath{..}+          [] -> TgtAndPath{..}+          [g] | g == pathGoal -> TgtAndPath{..}+            -- the exception is when the tile is explicitly targeted+          newGoal : _ ->+            let newTgt = TPoint TBlock (blid b) newGoal+                newPath = AndPath{ pathSource = bpos b+                                 , pathList = walkable  -- no @newGoal@+                                 , pathGoal = newGoal+                                 , pathLen = length walkable + 1 }+            in TgtAndPath{tapTgt = newTgt, tapPath = Just newPath}+      stopAtUnwalkable Nothing = TgtAndPath{tapTgt, tapPath=Nothing}+  mpos <- getsState $ aidTgtToPos (Just aid) (blid b) (Just tapTgt)+  case mpos of+    Nothing -> return TgtAndPath{tapTgt, tapPath=Nothing}+    Just p -> do+      path <- getCachePath aid p+      return $! stopAtUnwalkable path++condBFS :: MonadClientRead m => ActorId -> m (Bool, Word8)+condBFS aid = do+  side <- getsClient sside+  -- We assume the actor eventually becomes a leader (or has the same+  -- set of skills as the leader, anyway). Otherwise we'd have+  -- to reset BFS after leader changes, but it would still lead to+  -- wasted movement if, e.g., non-leaders move but only leaders open doors+  -- and leader change is very rare.+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let alterSkill =+        min (maxBound - 1)  -- @maxBound :: Word8@ means unalterable+            (toEnum $ max 0 $ Ability.getSk Ability.SkAlter actorMaxSk)+      canMove = Ability.getSk Ability.SkMove actorMaxSk > 0+                || Ability.getSk Ability.SkDisplace actorMaxSk > 0+                || Ability.getSk Ability.SkProject actorMaxSk > 0+  smarkSuspect <- getsClient smarkSuspect+  fact <- getsState $ (EM.! side) . sfactionD+  let -- Under UI, playing a hero party, we let AI set our target each+      -- turn for non-pointmen that can't move and can't alter,+      -- usually to TUnknown. This is rather useless, but correct.+      enterSuspect = smarkSuspect > 0 || gunderAI fact+      skill | enterSuspect = alterSkill  -- dig and search as skill allows+            | otherwise = 0  -- only walkable tiles+  return (canMove, skill)  -- keep it lazy++-- | Furthest (wrt paths) known position.+furthestKnown :: MonadClient m => ActorId -> m Point+furthestKnown aid = do+  bfs <- getCacheBfs aid+  getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA+                                     , PointArray.maxLastIndexA ]+  let furthestPos = getMaxIndex bfs+      dist = bfs PointArray.! furthestPos+  return $! assert (dist > apartBfs `blame` (aid, furthestPos, dist))+                   furthestPos++-- | Closest reachable unknown tile position, if any.+--+-- Note: some of these tiles are behind suspect tiles and they are chosen+-- in preference to more distant directly accessible unknown tiles.+-- This is in principle OK, but in dungeons with few hidden doors+-- AI is at a disadvantage (and with many hidden doors, it fares as well+-- as a human that deduced the dungeon properties). Changing Bfs to accomodate+-- all dungeon styles would be complex and would slow down the engine.+--+-- If the level has inaccessible open areas (at least from the stairs AI used)+-- the level will be nevertheless here finally labeled as explored,+-- to enable transition to other levels.+-- We should generally avoid such levels, because digging and/or trying+-- to find other stairs leading to disconnected areas is not KISS+-- so we don't do this in AI, so AI is at a disadvantage.+--+-- If the closest unknown is more than 126 tiles away from the targeting+-- actor, the level will marked as explored. We could complicate the code+-- and not mark if the unknown is too far as opposed to inaccessible,+-- but then if it is both too distant and inaccessible, AI would be+-- permanently stuck on such levels. To cope with this, escapes need to be+-- placed on open or small levels, or in dispersed enough that they don't+-- appear in such potentially unexplored potions of caves. Other than that,+-- this is rather harmless and hard to exploit, so let it be.+-- The principled way to fix this would be to extend BFS to @Word16@,+-- but then it takes too long to compute on maze levels, so we'd need+-- to optimize hard for JS.+closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)+closestUnknown aid = do+  body <- getsState $ getActorBody aid+  lvl <- getLevel $ blid body+  bfs <- getCacheBfs aid+  let closestPoss = PointArray.minIndexesA bfs+      dist = bfs PointArray.! head closestPoss+      !_A = assert (lexpl lvl >= lseen lvl) ()+  return $!+    if lexpl lvl <= lseen lvl+         -- Some unknown may still be visible and even pathable, but we already+         -- know from global level info that they are inaccessible.+       || dist >= apartBfs+         -- Global level info may tell us that terrain was changed and so+         -- some new explorable tile appeared, but we don't care about those+         -- and we know we already explored all initially seen unknown tiles+         -- and it's enough for us (otherwise we'd need to hunt all around+         -- the map for tiles altered by enemies).+    then Nothing+    else let unknownAround pos =+               let vic = vicinityUnsafe pos+                   countUnknown :: Int -> Point -> Int+                   countUnknown c p =+                     if isUknownSpace $ lvl `at` p then c + 1 else c+               in foldl' countUnknown 0 vic+             cmp = comparing unknownAround+         in Just $ maximumBy cmp closestPoss++-- | Finds smells closest to the actor, except under the actor,+-- because actors consume smell only moving over them, not standing.+-- Of the closest, prefers the newest smell.+closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Time))]+closestSmell aid = do+  body <- getsState $ getActorBody aid+  Level{lsmell, ltime} <- getLevel $ blid body+  let smells = filter (\(p, sm) -> sm > ltime && p /= bpos body)+                      (EM.assocs lsmell)+  case smells of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells+      return $! sortOn (fst &&& absoluteTimeNegate . snd . snd) ts++data FleeViaStairsOrEscape =+    ViaStairs+  | ViaStairsUp+  | ViaStairsDown+  | ViaEscape+  | ViaExit  -- can change whenever @sexplored@ changes+  | ViaNothing+  | ViaAnything+  deriving (Show, Eq)++embedBenefit :: MonadClientRead m+             => FleeViaStairsOrEscape -> ActorId+             -> [(Point, ItemBag)]+             -> m [(Double, (Point, ItemBag))]+embedBenefit fleeVia aid pbags = do+  COps{cocave, coTileSpeedup} <- getsState scops+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  lvl <- getLevel (blid b)+  oursExploring <- getsState $ oursExploringAssocs (bfid b)+  let oursExploringLid =+        filter (\(_, body) -> blid body == blid b) oursExploring+      spawnFreqs = CK.cactorFreq $ okind cocave $ lkind lvl+      hasGroup grp = fromMaybe 0 (lookup grp spawnFreqs) > 0+      lvlSpawnsUs = any (hasGroup . fst) $ filter ((> 0) . snd)+                                         $ fgroups (gkind fact)+  actorSk <- if fleeVia `elem` [ViaAnything, ViaExit]+                  -- targeting, possibly when not a leader+             then getsState $ getActorMaxSkills aid+             else currentSkillsClient aid+  let alterSkill = Ability.getSk Ability.SkAlter actorSk+  condOurAdj <- getsState $ any (\(_, b2) -> isFriend (bfid b) fact (bfid b2))+                            . adjacentBigAssocs b+  unexploredTrue <- unexploredDepth True (blid b)+  unexploredFalse <- unexploredDepth False (blid b)+  condEnoughGear <- condEnoughGearM aid+  discoBenefit <- getsClient sdiscoBenefit+  getKind <- getsState $ flip getIidKind+  let alterMinSkill p = Tile.alterMinSkill coTileSpeedup $ lvl `at` p+      lidExplored = ES.member (blid b) explored+      allExplored = ES.size explored == EM.size dungeon+      -- Ignoring the number of items, because only one of each @iid@+      -- is triggered at the same time, others are left to be used later on.+      -- Taking the kind the item hides under into consideration, because+      -- it's a best guess only, for AI and UI.+      iidToEffs iid = IK.ieffects $ getKind iid+      feats bag = concatMap iidToEffs $ EM.keys bag+      -- For simplicity, we assume at most one exit at each position.+      -- AI uses exit regardless of traps or treasures at the spot.+      bens (_, bag) = case find IK.isEffEscapeOrAscend $ feats bag of+        Just IK.Escape{} ->+          -- Escape (or guard) only after exploring, for high score, etc.+          let escapeOrGuard =+                fcanEscape (gkind fact)+                || fleeVia == ViaExit  -- target to guard after explored+          in if fleeVia `elem` [ViaAnything, ViaEscape, ViaExit]+                && escapeOrGuard+                && allExplored+             then 10+             else 0  -- don't escape prematurely+        Just (IK.Ascend up) ->  -- change levels sensibly, in teams+          let easier = up /= (fromEnum (blid b) > 0)+              unexpForth = if up then unexploredTrue else unexploredFalse+              unexpBack = if not up then unexploredTrue else unexploredFalse+              -- Forbid loops via peeking at unexplored and getting back.+              aiCond = if unexpForth+                       then easier && condEnoughGear+                            || (not unexpBack || easier) && lidExplored+                       else not unexpBack && easier && allExplored+                            && null (lescape lvl)+              -- Prefer one direction of stairs, to team up+              -- and prefer embed (may, e.g., create loot) over stairs.+              v = if aiCond then if easier then 10 else 1 else 0+              guardingStash = case gstash fact of+                Nothing -> False+                Just (lid, p) ->+                  lid == blid b+                  && (length oursExploring > 1+                      || lvlSpawnsUs)+                  && (length oursExploringLid <= 1+                        -- not @==@ in case guard temporarily nonmoving+                      || p == bpos b && not condOurAdj)+                           -- don't leave the post; let the others explore+          in case fleeVia of+            _ | guardingStash -> 0+            ViaStairsUp | up -> 1+            ViaStairsDown | not up -> 1+            ViaStairs -> v+            ViaExit -> v+            ViaAnything -> v+            _ -> 0  -- don't ascend prematurely+        _ ->+          if fleeVia `elem` [ViaNothing, ViaAnything]+          then -- Actor uses the embedded item on himself, hence @benApply@.+               -- Let distance be the deciding factor and also prevent+               -- overflow on 32-bit machines.+               let sacrificeForExperiment = 101  -- single explosion acceptable+                   sumBen = sum $ map (\iid ->+                     benApply $ discoBenefit EM.! iid) (EM.keys bag)+               in min 1000 $ sacrificeForExperiment + sumBen+          else 0+      underFeet p = p == bpos b  -- if enter and alter, be more permissive+      -- Only actors with high enough @SkAlter@ can trigger terrain.+      -- Blocking actors and items not checked, because they can be moved+      -- before the actor gets to the location, or after.+      f (p, _) = underFeet p+                 || alterSkill >= fromEnum (alterMinSkill p)+                 || Tile.isSuspect coTileSpeedup (lvl `at` p)+                    && alterSkill >= 2+      benFeats = map (\pbag -> (bens pbag, pbag)) $ filter f pbags+      considered (benefitAndSacrifice, (p, _bag)) =+        benefitAndSacrifice > 0+        -- For speed and to avoid greedy AI loops, only experiment with few.+        && Tile.consideredByAI coTileSpeedup (lvl `at` p)+  return $! filter considered benFeats++-- | Closest (wrt paths) AI-triggerable tiles with embedded items.+-- In AI, the level the actor is on is either explored or the actor already+-- has a weapon equipped, so no need to explore further, he tries to find+-- enemies on other levels, but before that, he triggers other tiles+-- in hope of some loot or beneficial effect to enter next level with.+closestTriggers :: MonadClient m => FleeViaStairsOrEscape -> ActorId+                -> m [(Int, (Point, (Point, ItemBag)))]+closestTriggers fleeVia aid = do+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel (blid b)+  let pbags = EM.assocs $ lembed lvl+  efeat <- embedBenefit fleeVia aid pbags+  -- The advantage of targeting the tiles in vicinity of triggers is that+  -- triggers don't need to be pathable (and so AI doesn't bump into them+  -- by chance while walking elsewhere) and that many accesses to the tiles+  -- are more likely to be targeted by different AI actors (even starting+  -- from the same location), so there is less risk of clogging stairs and,+  -- OTOH, siege of stairs or escapes is more effective.+  bfs <- getCacheBfs aid+  let vicTrigger (cid, (p0, bag)) =+        map (\p -> (cid, (p, (p0, bag))))+            (vicinityBounded rWidthMax rHeightMax p0)+      vicAll = concatMap vicTrigger efeat+  return $!+    let mix (benefit, ppbag) dist =+          let maxd = subtractBfsDistance maxBfsDistance apartBfs+              v = intToDouble $ maxd `div` (dist + 1)+          in (ceiling $ benefit * v, ppbag)+    in mapMaybe (\bpp@(_, (p, _)) ->+         mix bpp <$> accessBfs bfs p) vicAll++-- | Check whether the actor has enough gear to go look for enemies.+-- We assume weapons in equipment are better than any among organs+-- or at least provide some essential diversity.+-- Disabled if, due to doctrine, actors follow leader and so would+-- repeatedly move towards and away from stairs at leader change,+-- depending on current leader's gear.+-- Number of items of a single kind is ignored, because variety is needed.+condEnoughGearM :: MonadClientRead m => ActorId -> m Bool+condEnoughGearM aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let followDoctrine =+        gdoctrine fact `elem` [Ability.TFollow, Ability.TFollowNoItems]+  eqpAssocs <- getsState $ fullAssocs aid [CEqp]+  return $ not followDoctrine  -- keep it lazy+           && (any (IA.checkFlag Ability.Meleeable+                    . aspectRecordFull . snd) eqpAssocs+               || length eqpAssocs >= 3)++unexploredDepth :: MonadClientRead m => Bool -> LevelId -> m Bool+unexploredDepth !up !lidCurrent = do+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  let allExplored = ES.size explored == EM.size dungeon+      unexploredD =+        let unex !lid = allExplored+                        && not (null $ lescape $ dungeon EM.! lid)+                        || ES.notMember lid explored+                        || unexploredD lid+        in any unex . ascendInBranch dungeon up+  return $ unexploredD lidCurrent  -- keep it lazy++-- | Closest (wrt paths) items.+closestItems :: MonadClient m => ActorId -> m [(Int, (Point, ItemBag))]+closestItems aid = do+  body <- getsState $ getActorBody aid+  Level{lfloor, lbig} <- getLevel $ blid body+  factionD <- getsState sfactionD+  per <- getPerFid $ blid body+  let canSee p = ES.member p (totalVisible per)+  -- Don't consider items at any stash location that an actor stands over+  -- or can stand over, but it's out of our LOS.+  -- In case of the own stash, don't consider regardless of actors and LOS.+  -- Own stash items are already owned, enemy stash is already targetted+  -- and allied or neutral stashes with actors on top are unlikely+  -- to be vacated and cause AI to wonder around forever or look up,+  -- leave, return hopeful, find a guard, repeat.+  let stashes = map (second gstash) $ EM.assocs factionD+      stashToRemove :: (FactionId, Maybe (LevelId, Point)) -> [Point]+      stashToRemove (fid, Just (lid, pos))+        | lid == blid body+          && (fid == bfid body || pos `EM.member` lbig || not (canSee pos)) =+            [pos]+      stashToRemove _ = []+      stashesToRemove = ES.fromList $ concatMap stashToRemove stashes+      lfloorBarStashes = EM.withoutKeys lfloor stashesToRemove+  if EM.null lfloorBarStashes then return [] else do+    bfs <- getCacheBfs aid+    let mix pbag dist =+          let maxd = subtractBfsDistance maxBfsDistance apartBfs+              -- Beware of overflowing 32-bit integers.+              -- Here distance is the only factor influencing frequency.+              -- Whether item is desirable is checked later on.+              v = (maxd * 10) `div` (dist + 1)+          in (v, pbag)+    return $! mapMaybe (\(p, bag) ->+      mix (p, bag) <$> accessBfs bfs p) (EM.assocs lfloorBarStashes)++-- | Closest (wrt paths) enemy actors.+closestFoes :: MonadClient m+            => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]+closestFoes foes aid =+  case foes of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes+      return $! sortBy (comparing fst) ds++-- | Closest (wrt paths) enemy or our unguarded stash locations. If it's ours,+-- we want to guard it, it enemy, loot it. Neutral and friendly stashes+-- not chased to avoid loops of bloodless takeovers.+closestStashes :: MonadClient m => ActorId -> m [(Int, (FactionId, Point))]+closestStashes aid = do+  COps{cocave} <- getsState scops+  factionD <- getsState sfactionD+  b <- getsState $ getActorBody aid+  lvl <- getLevel (blid b)+  oursExploring <- getsState $ oursExploringAssocs (bfid b)+  let fact = factionD EM.! bfid b+      spawnFreqs = CK.cactorFreq $ okind cocave $ lkind lvl+      hasGroup grp = fromMaybe 0 (lookup grp spawnFreqs) > 0+      lvlSpawnsUs = any (hasGroup . fst) $ filter ((> 0) . snd)+                                         $ fgroups (gkind fact)+      qualifyStash (fid2, Faction{gstash}) = case gstash of+        Nothing -> Nothing+        Just (lid, pos) ->+          -- The condition below is more strict that in @updateTgt@+          -- to avoid loops by changing target of actor displacing+          -- and walking over stash to @TStash@.+          if lid == blid b+             && (fid2 == bfid b+                 && isNothing (posToBigLvl pos lvl)  -- unguarded+                 && (length oursExploring > 1  -- other actors able to explore+                     || lvlSpawnsUs)  -- or future spawned will be able+                 || isFoe (bfid b) fact fid2)+          then Just (fid2, pos)+          else Nothing+  case mapMaybe qualifyStash $ EM.assocs factionD of+    [] -> return []+    stashes -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\x@(_, pos) -> fmap (,x) (accessBfs bfs pos)) stashes+      return $! sortBy (comparing fst) ds++oursExploringAssocs :: FactionId -> State -> [(ActorId, Actor)]+oursExploringAssocs fid s =+  let f (!aid, !b) = bfid b == fid+                     && not (bproj b)+                     && bhp b > 0  -- dead can stay forever on a frozen level+                     && (bwatch b `elem` [WSleep, WWake]+                           -- if asleep, probably has walking skill normally;+                           -- when left alone will wake up and guard or explore+                        || let actorMaxSk = sactorMaxSkills s EM.! aid+                           in Ability.getSk Ability.SkMove actorMaxSk > 0+                              || Ability.getSk Ability.SkMove actorMaxSk < -50)+                                   -- a hacky way to rule out tmp immobile+  in filter f $ EM.assocs $ sactorD s++-- | Find the nearest walkable position in dark, if any. Deterministic,+-- to let all friends gather up and defend in the same shelter.+-- Ignore position underfoot.+closestHideout :: MonadClient m => ActorId -> m (Maybe (Point, Int))+closestHideout aid = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel (blid b)+  bfs <- getCacheBfs aid+  let minHideout :: (Point, BfsDistance) -> Point -> BfsDistance+                 -> (Point, BfsDistance)+      minHideout (pMin, distMin) p dist =+        if dist > minKnownBfs && dist < distMin+           && Tile.isHideout coTileSpeedup (lvl `at` p)+        then (p, dist)+        else (pMin, distMin)+      (p1, dist1) = PointArray.ifoldlA' minHideout (bpos b, maxBfsDistance) bfs+  return $! if p1 == bpos b  -- possibly hideout underfoot; ignore+            then Nothing+            else Just (p1, subtractBfsDistance dist1 apartBfs)
+ engine-src/Game/LambdaHack/Client/CommonM.hs view
@@ -0,0 +1,185 @@+-- | Common client monad operations.+module Game.LambdaHack.Client.CommonM+  ( getPerFid, aidTgtToPos, makeLine+  , currentSkillsClient, pickWeaponClient+  , updateSalter, createSalter+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | Get the current perception of a client.+getPerFid :: MonadClientRead m => LevelId -> m Perception+getPerFid lid = do+  fper <- getsClient sfper+  let assFail = error $ "no perception at given level"+                        `showFailure` (lid, fper)+  return $! EM.findWithDefault assFail lid fper++-- | Calculate the position of an actor's target.+-- This matches @pathGoal@, but sometimes path is not defined.+aidTgtToPos :: Maybe ActorId -> LevelId -> Maybe Target -> State -> Maybe Point+aidTgtToPos _ _ Nothing _ = Nothing+aidTgtToPos maid lidV (Just tgt) s = case tgt of+  TEnemy a ->+    let body = getActorBody a s+    in if blid body == lidV then Just (bpos body) else Nothing+  TNonEnemy a ->+    let body = getActorBody a s+    in if blid body == lidV then Just (bpos body) else Nothing+  TPoint _ lid p ->+    if lid == lidV then Just p else Nothing+  TVector v -> case maid of+    Nothing -> Nothing+    Just aid ->+      let COps{corule=RuleContent{rWidthMax, rHeightMax}} = scops s+          b = getActorBody aid s+          shifted = shiftBounded rWidthMax rHeightMax (bpos b) v+      in if shifted == bpos b && v /= Vector 0 0 then Nothing else Just shifted++-- | Counts the number of steps until the projectile would hit a non-projectile+-- actor or obstacle. Starts searching with the given eps and returns+-- the first found eps for which the number reaches the distance between+-- actor and target position, or Nothing if none can be found.+-- Treats unknown tiles as walkable, but prefers known.+makeLine :: Bool -> Actor -> Point -> Int -> COps -> Level -> Maybe Int+makeLine onlyFirst body fpos epsOld cops lvl =+  let COps{coTileSpeedup} = cops+      dist = chessDist (bpos body) fpos+      calcScore :: Int -> Int+      calcScore eps = case bresenhamsLineAlgorithm eps (bpos body) fpos of+        Just bl ->+          let blDist = take (dist - 1) bl  -- goal not checked; actor well aware+              noActor p = p == fpos || not (occupiedBigLvl p lvl)+              accessibleUnknown tpos =+                let tt = lvl `at` tpos+                in Tile.isWalkable coTileSpeedup tt || isUknownSpace tt+              accessU = all noActor blDist+                        && all accessibleUnknown blDist+              accessFirst | not onlyFirst = False+                          | otherwise =+                all noActor (take 1 blDist)+                && all accessibleUnknown (take 1 blDist)+              nUnknown = length $ filter (isUknownSpace . (lvl `at`)) blDist+          in if | accessU -> - nUnknown+                | accessFirst -> -10000+                | otherwise -> minBound+        Nothing -> error $ "" `showFailure` (body, fpos, epsOld)+      tryLines :: Int -> (Maybe Int, Int) -> Maybe Int+      tryLines curEps (acc, _) | curEps == epsOld + dist = acc+      tryLines curEps (acc, bestScore) =+        let curScore = calcScore curEps+            newAcc = if curScore > bestScore+                     then (Just curEps, curScore)+                     else (acc, bestScore)+        in tryLines (curEps + 1) newAcc+  in if | dist <= 0 -> Nothing  -- ProjectAimOnself+        | calcScore epsOld > minBound -> Just epsOld  -- keep old+        | otherwise -> tryLines (epsOld + 1) (Nothing, minBound)  -- find best++-- @MonadStateRead@ would be enough, but the logic is sound only on client.+currentSkillsClient :: MonadClientRead m => ActorId -> m Ability.Skills+currentSkillsClient aid = do+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  -- Newest Leader in sleader, not yet in sfactionD.+  mleader <- if bfid body == side+             then getsClient sleader+             else do+               fact <- getsState $ (EM.! bfid body) . sfactionD+               return $! gleader fact+  getsState $ actorCurrentSkills mleader aid  -- keep it lazy++-- Client has to choose the weapon based on its partial knowledge,+-- because if server chose it, it would leak item discovery information.+--+-- Note that currently the aspects of the target actor are not considered,+-- because all weapons share the sum of all source actor aspects and only differ+-- in damage (equally important for all targets) and effects (really hard+-- to tell which is better for which target or even which is better+-- for the same target, so it's random). If only individual weapon's +toHit+-- was applied to the target, situation would be much more complex,+-- which is precisely why we keep it as is and let the player make choices+-- by equipping and unequipping weapons instead. Content should ensure+-- that the rule of thumb (which AI uses) that more weapons is better+-- should give good results almost always, at least at the start of the game,+-- to limit micromanagement and to spare newbies.+--+-- Note that situation is completely different with choosing projectiles+-- against a particular foe, even before (potential) splash damage+-- that hits multiple tagets comes into the equation. AI has to be very+-- primitive and random here as well.+pickWeaponClient :: MonadClient m+                 => ActorId -> ActorId -> m (Maybe RequestTimed)+pickWeaponClient source target = do+  eqpAssocs <- getsState $ kitAssocs source [CEqp]+  bodyAssocs <- getsState $ kitAssocs source [COrgan]+  actorSk <- currentSkillsClient source+  tb <- getsState $ getActorBody target+  let kitAssRaw = eqpAssocs ++ bodyAssocs+      kitAss = filter (IA.checkFlag Ability.Meleeable+                       . aspectRecordFull . fst . snd) kitAssRaw+      benign itemFull = let arItem = aspectRecordFull itemFull+                        in IA.checkFlag Ability.Benign arItem+  discoBenefit <- getsClient sdiscoBenefit+  strongest <- pickWeaponM False (Just discoBenefit) kitAss actorSk source+  case strongest of+    [] -> return Nothing+    (_, _, _, _, _, (itemFull, _)) : _ | benign itemFull && bproj tb ->+      return Nothing  -- if strongest is benign, don't waste fun on a projectile+    iis@(ii1@(value1, hasEffect1, timeout1, _, _, (itemFull1, _)) : _) -> do+      let minIis = takeWhile (\(value, hasEffect, timeout, _, _, _) ->+                                 value == value1+                                 && hasEffect == hasEffect1+                                 && timeout == timeout1)+                             iis+      -- Randomize only the no-timeout items. Others need to activate+      -- in the order shown in HUD and also not risk of only one always used.+      (_, _, _, _, iid, _) <- if timeout1 > 0 || itemSuspect itemFull1+                              then return ii1+                              else rndToAction $ oneOf minIis+      -- Prefer COrgan, to hint to the player to trash the equivalent CEqp item.+      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp+      return $ Just $ ReqMelee target iid cstore++updateSalter :: MonadClient m+             => LevelId -> [(Point, ContentId TileKind)] -> m ()+updateSalter lid pts = do+  COps{coTileSpeedup} <- getsState scops+  let pas = map (second $ toEnum . Tile.alterMinWalk coTileSpeedup) pts+      f = (PointArray.// pas)+  modifyClient $ \cli -> cli {salter = EM.adjust f lid $ salter cli}++createSalter :: State -> AlterLid+createSalter s =+  let COps{coTileSpeedup} = scops s+      f Level{ltile} =+        PointArray.mapA (toEnum . Tile.alterMinWalk coTileSpeedup) ltile+  in EM.map f $ sdungeon s
+ engine-src/Game/LambdaHack/Client/HandleAtomicM.hs view
@@ -0,0 +1,483 @@+-- | Handle atomic commands received by the client.+module Game.LambdaHack.Client.HandleAtomicM+  ( MonadClientSetup(..)+  , cmdAtomicSemCli+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , updateInMeleeDueToActor, updateInMeleeDueToItem, updateInMeleeInDungeon+  , wipeBfsIfItemAffectsSkills, tileChangeAffectsBfs+  , createActor, destroyActor+  , addItemToDiscoBenefit, perception+  , discoverKind, discoverKindAndAspect, coverKind, coverAspectAndKind+  , discoverAspect, coverAspect+  , killExit+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Preferences+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.CaveKind as CK+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.TileKind (TileKind)+import           Game.LambdaHack.Definition.Defs++-- | Client monad for saving a game.+class MonadClient m => MonadClientSetup m where+  saveClient    :: m ()++-- | Effect of atomic actions on client state. It is calculated+-- with the global state from after the command is executed+-- (except where the supplied @oldState@ is used).+cmdAtomicSemCli :: MonadClientSetup m => State -> UpdAtomic -> m ()+{-# INLINE cmdAtomicSemCli #-}+cmdAtomicSemCli oldState cmd = case cmd of+  UpdRegisterItems ais -> mapM_ (addItemToDiscoBenefit . fst) ais+  UpdCreateActor aid b ais -> createActor aid b ais+  UpdDestroyActor aid b _ -> destroyActor aid b True+  UpdCreateItem _ iid _ _ (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills store aid+    addItemToDiscoBenefit iid+    updateInMeleeDueToItem aid store+  UpdCreateItem _ iid _ _ _ -> addItemToDiscoBenefit iid+  UpdDestroyItem _ _ _ _ (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills store aid+    updateInMeleeDueToItem aid store+  UpdDestroyItem{} -> return ()+  UpdSpotActor aid b -> do+    ais <- getsState $ getCarriedAssocsAndTrunk b+    createActor aid b ais+  UpdLoseActor aid b -> destroyActor aid b False+  UpdSpotItem _ iid _ (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills store aid+    addItemToDiscoBenefit iid+    updateInMeleeDueToItem aid store+  UpdSpotItem _ iid _ _ -> addItemToDiscoBenefit iid+  UpdLoseItem _ _ _ (CActor aid store) -> do+    wipeBfsIfItemAffectsSkills store aid+    updateInMeleeDueToItem aid store+  UpdLoseItem{} -> return ()+  UpdSpotItemBag _ (CActor aid store) bag -> do+    wipeBfsIfItemAffectsSkills store aid+    mapM_ addItemToDiscoBenefit $ EM.keys bag+    updateInMeleeDueToItem aid store+  UpdSpotItemBag _ _ bag ->+    mapM_ addItemToDiscoBenefit $ EM.keys bag+  UpdLoseItemBag _ (CActor aid store) _ -> do+    wipeBfsIfItemAffectsSkills store aid+    updateInMeleeDueToItem aid store+  UpdLoseItemBag{} -> return ()+  UpdMoveActor aid _ _ -> do+    invalidateBfsAid aid+    -- other BFSes not invalidated, because distant actors may still move out+    -- of the way and close actors are considered when attempting to move+    -- and then BFS is invalidated, if needed.+    b <- getsState $ getActorBody aid+    updateInMeleeDueToActor b+  UpdWaitActor aid _fromW toW -> do+    -- So that we can later ignore such actors when updating targets+    -- and not risk they being pushed/displaced and targets getting illegal.+    when (toW == WSleep) $+      modifyClient $ updateTarget aid (const Nothing)+    b <- getsState $ getActorBody aid+    updateInMeleeDueToActor b  -- @bwatch@ checked in several places+  UpdDisplaceActor source target -> do+    invalidateBfsAid source+    invalidateBfsAid target+    -- other BFSes not invalidated, because distant actors may still move out+    -- of the way and close actors are considered when attempting to move+    -- and then BFS is invalidated, if needed.+    sb <- getsState $ getActorBody source+    -- At least one of these is not a projectile and both move, so update.+    insertInMeleeM (blid sb)+  UpdMoveItem _ _ aid s1 s2 -> do+    wipeBfsIfItemAffectsSkills s1 aid+    wipeBfsIfItemAffectsSkills s2 aid+    updateInMeleeDueToItem aid s1+    updateInMeleeDueToItem aid s2+  UpdRefillHP _ 0 -> return ()+  UpdRefillHP aid delta -> do+    b <- getsState $ getActorBody aid+    unless (bproj b+            || signum (bhp b)  -- new HP+               == signum (bhp b - delta)) $  -- old HP+      insertInMeleeM (blid b)  -- @bhp@ checked in several places+  UpdRefillCalm{} -> return ()+  UpdTrajectory{} -> return ()+  UpdQuitFaction{} -> return ()+  UpdSpotStashFaction{} -> return ()+  UpdLoseStashFaction{} -> return ()+  UpdLeadFaction fid source target -> do+    side <- getsClient sside+    when (side == fid) $ do+      mleader <- getsClient sleader+      let !_A = assert (mleader == source+                          -- somebody changed the leader for us+                        || mleader == target+                          -- we changed the leader ourselves+                        `blame` "unexpected leader"+                        `swith` (cmd, mleader)) ()+      modifyClient $ \cli -> cli {_sleader = target}+  UpdDiplFaction{} ->+    -- Depends on who is a foe as opposed to a neutral actor.+    updateInMeleeInDungeon+  UpdAutoFaction{} -> do+    -- Regaining control of faction cancels some --stopAfter*.+    -- This is really a UI client issue, but is in general client state+    -- to make it simpler to set this via commandline.+    modifyClient $ \cli ->+      cli {soptions = (soptions cli) { sstopAfterSeconds = Nothing+                                     , sstopAfterFrames = Nothing }}+    -- @condBFS@ depends on the setting we change here (e.g., smarkSuspect).+    invalidateBfsAll+  UpdRecordKill{} -> return ()+  UpdDoctrineFaction{} -> do+    -- Clear all targets except the leader's.+    mleader <- getsClient sleader+    mtgt <- case mleader of+      Nothing -> return Nothing+      Just leader -> getsClient $ EM.lookup leader . stargetD+    modifyClient $ \cli ->+      let stargetD | Just tgt <- mtgt+                   , Just leader <- mleader+                   = EM.singleton leader tgt+                   | otherwise = EM.empty+      in cli {stargetD}+  UpdAlterTile lid p fromTile toTile -> do+    updateSalter lid [(p, toTile)]+    cops <- getsState scops+    let lvl = (EM.! lid) . sdungeon $ oldState+        t = lvl `at` p+    let !_A = assert (t == fromTile) ()+    when (tileChangeAffectsBfs cops fromTile toTile) $+      invalidateBfsLid lid+  UpdAlterExplorable{} -> return ()+  UpdAlterGold{} -> return ()+  UpdSearchTile aid p toTile -> do+    COps{cotile} <- getsState scops+    b <- getsState $ getActorBody aid+    let lid = blid b+    updateSalter lid [(p, toTile)]+    cops <- getsState scops+    let lvl = (EM.! lid) . sdungeon $ oldState+        t = lvl `at` p+    let !_A = assert (Just t == Tile.hideAs cotile toTile) ()+    -- The following check is needed even if we verity in content+    -- that searching doesn't change clarity and light of tiles,+    -- because it modifies skill needed to alter the tile and even+    -- walkability and changeability.+    when (tileChangeAffectsBfs cops t toTile) $+      invalidateBfsLid lid+  UpdHideTile{} -> return ()+  UpdSpotTile lid ts -> do+    updateSalter lid ts+    cops <- getsState scops+    let lvl = (EM.! lid) . sdungeon $ oldState+        affects (p, toTile) =+          let fromTile = lvl `at` p+          in tileChangeAffectsBfs cops fromTile toTile+        bs = map affects ts+    when (or bs) $ invalidateBfsLid lid+  UpdLoseTile lid ts -> do+    updateSalter lid ts+    invalidateBfsLid lid  -- from known to unknown tiles+  UpdSpotEntry{} -> return ()+  UpdLoseEntry{} -> return ()+  UpdAlterSmell{} -> return ()+  UpdSpotSmell{} -> return ()+  UpdLoseSmell{} -> return ()+  UpdTimeItem{} -> return ()+  UpdAgeGame{} -> return ()+  UpdUnAgeGame{} -> return ()+  UpdDiscover _ iid _ _ -> do+    item <- getsState $ getItemBody iid+    case jkind item of+      IdentityObvious _ik -> discoverAspect iid+      IdentityCovered ix _ik ->+        if ix `EM.notMember` sdiscoKind oldState+        then discoverKindAndAspect ix+        else discoverAspect iid+  UpdCover _ iid _ _ -> do+    item <- getsState $ getItemBody iid+    newState <- getState+    case jkind item of+      IdentityObvious _ik -> coverAspect iid+      IdentityCovered ix _ik ->+        if ix `EM.member` sdiscoKind newState+        then coverAspectAndKind ix+        else coverAspect iid+  UpdDiscoverKind _c ix _ik -> discoverKind ix+  UpdCoverKind _c ix _ik -> coverKind ix+  UpdDiscoverAspect _c iid _arItem -> discoverAspect iid+  UpdCoverAspect _c iid _arItem -> coverAspect iid+  UpdDiscoverServer{} -> error "server command leaked to client"+  UpdCoverServer{} -> error "server command leaked to client"+  UpdPerception lid outPer inPer -> perception lid outPer inPer+  UpdRestart side sfper _ scurChal soptionsNew srandom -> do+    COps{cocave} <- getsState scops+    fact <- getsState $ (EM.! side) . sfactionD+    snxtChal <- getsClient snxtChal+    smarkSuspect <- getsClient smarkSuspect+    stabs <- getsClient stabs+    soptionsOld <- getsClient soptions+    let h lvl = CK.clabyrinth (okind cocave $ lkind lvl)+                && not (fhasGender $ gkind fact)+          -- Not to burrow through a labyrinth instead of leaving it for+          -- the human player and to prevent AI losing time there instead+          -- of congregating at exits.+    sexplored <- getsState $ EM.keysSet . EM.filter h . sdungeon+    let cli = emptyStateClient side+    putClient cli { sexplored+                  -- , sundo = [UpdAtomic cmd]+                  , sfper+                  , srandom+                  , scurChal+                  , snxtChal+                  , smarkSuspect+                  , soptions =+                      soptionsNew {snoAnim =  -- persist @snoAnim@ between games+                        snoAnim soptionsOld `mplus` snoAnim soptionsNew}+                  , stabs }+    salter <- getsState createSalter+    modifyClient $ \cli1 -> cli1 {salter}+    updateInMeleeInDungeon+  UpdRestartServer{} -> return ()+  UpdResume _side sfperNew -> do+#ifdef WITH_EXPENSIVE_ASSERTIONS+    sfperOld <- getsClient sfper+    let !_A = assert (sfperNew == sfperOld+                      `blame` (_side, sfperNew, sfperOld)) ()+#endif+    modifyClient $ \cli -> cli {sfper = sfperNew}  -- just in case+    salter <- getsState createSalter  -- because space saved by not storing it+    modifyClient $ \cli -> cli {salter}+  UpdResumeServer{} -> return ()+  UpdKillExit _fid -> killExit+  UpdWriteSave -> saveClient+  UpdHearFid{} -> return ()+  UpdMuteMessages{} -> return ()++updateInMeleeDueToActor :: MonadClient m => Actor -> m ()+updateInMeleeDueToActor b =+  unless (bproj b) $+    insertInMeleeM (blid b)++updateInMeleeDueToItem :: MonadClient m => ActorId -> CStore -> m ()+updateInMeleeDueToItem aid store =+  when (store `elem` [CEqp, COrgan]) $ do+    b <- getsState $ getActorBody aid+    updateInMeleeDueToActor b++updateInMeleeInDungeon :: MonadClient m => m ()+updateInMeleeInDungeon = do+  dungeon <- getsState sdungeon+  mapM_ insertInMeleeM $ EM.keys dungeon++-- For now, only checking the stores.+wipeBfsIfItemAffectsSkills :: MonadClient m => CStore -> ActorId -> m ()+wipeBfsIfItemAffectsSkills store aid =+  when (store `elem` [CEqp, COrgan]) $+    invalidateBfsAid aid++tileChangeAffectsBfs :: COps+                     -> ContentId TileKind -> ContentId TileKind+                     -> Bool+tileChangeAffectsBfs COps{coTileSpeedup} fromTile toTile =+  Tile.alterMinWalk coTileSpeedup fromTile+  /= Tile.alterMinWalk coTileSpeedup toTile++createActor :: MonadClient m => ActorId -> Actor -> [(ItemId, Item)] -> m ()+createActor aid b ais = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let affect3 tap@TgtAndPath{..} = case tapTgt of+        TPoint (TEnemyPos a) _ _ | a == aid ->+          let tgt | isFoe side fact (bfid b) = TEnemy a  -- still a foe+                  | otherwise = TPoint TKnown (blid b) (bpos b)+          in TgtAndPath tgt Nothing+        _ -> tap+  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}+  mapM_ (addItemToDiscoBenefit . fst) ais+  unless (bproj b) $ invalidateBfsPathLid b+  updateInMeleeDueToActor b++destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m ()+destroyActor aid b destroy = do+  when destroy $  -- if vanishes for a moment only, keep target+    modifyClient $ \cli -> cli {stargetD = EM.delete aid $ stargetD cli} -- gc+  -- Here, among others, (local) flee time of an actor changing level is reset.+  modifyClient $ \cli -> cli { sbfsD = EM.delete aid $ sbfsD cli+                             , sfleeD = EM.delete aid $ sfleeD cli }+  localTime <- getsState $ getLocalTime $ blid b+  fleeD <- getsClient sfleeD+  let recentlyFled aid3 = maybe False (\(_, time) -> timeRecent5 localTime time)+                                (aid3 `EM.lookup` fleeD)+      dummyTarget = TPoint TKnown (blid b) (bpos b)+      affect aid3 tgt = case tgt of+        TEnemy a | a == aid ->+          if destroy || recentlyFled aid3+                          -- if fleeing, don't chase the enemy soon after;+                          -- unfortunately, the enemy also won't be recorded+                          -- in case he gets out of sight, in order to avoid+                          -- him when fleeing again, but all enemies should be+                          -- recorded in such a case, so not a big difference+          then+            -- If *really* nothing more interesting, the actor will+            -- go to last known location to perhaps find other foes.+            dummyTarget+          else+            -- If enemy only hides (or we stepped behind obstacle) find him.+            TPoint (TEnemyPos a) (blid b) (bpos b)+        TNonEnemy a | a == aid -> dummyTarget+        _ -> tgt+      affect3 aid3 TgtAndPath{..} =+        let newMPath = case tapPath of+              Just AndPath{pathGoal} | pathGoal /= bpos b -> Nothing+              _ -> tapPath  -- foe slow enough, so old path good+        in TgtAndPath (affect aid3 tapTgt) newMPath+  modifyClient $ \cli -> cli {stargetD = EM.mapWithKey affect3 (stargetD cli)}+  unless (bproj b) $ invalidateBfsPathLid b+  updateInMeleeDueToActor b++addItemToDiscoBenefit :: MonadClient m => ItemId -> m ()+addItemToDiscoBenefit iid = do+  cops <- getsState scops+  discoBenefit <- getsClient sdiscoBenefit+  case EM.lookup iid discoBenefit of+    Just{} -> return ()+      -- already there, with real or provisional aspect record,+      -- but we haven't learned anything new about the item+    Nothing -> do+      side <- getsClient sside+      factionD <- getsState sfactionD+      itemFull <- getsState $ itemToFull iid+      let benefit = totalUsefulness cops side factionD itemFull+      modifyClient $ \cli ->+        cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)}++perception :: MonadClient m => LevelId -> Perception -> Perception -> m ()+perception lid outPer inPer = do+  -- Clients can't compute FOV on their own, because they don't know+  -- if unknown tiles are clear or not. Server would need to send+  -- info about properties of unknown tiles, which complicates+  -- and makes heavier the most bulky data set in the game: tile maps.+  -- Note we assume, but do not check that @outPer@ is contained+  -- in current perception and @inPer@ has no common part with it.+  -- It would make the already very costly operation even more expensive.+{-+  perOld <- getPerFid lid+  -- Check if new perception is already set in @cmdAtomicFilterCli@+  -- or if we are doing undo/redo, which does not involve filtering.+  -- The data structure is strict, so the cheap check can't be any simpler.+  let interAlready per =+        Just $ totalVisible per `ES.intersection` totalVisible perOld+      unset = maybe False ES.null (interAlready inPer)+              || maybe False (not . ES.null) (interAlready outPer)+  when unset $ do+-}+    let adj Nothing = error $ "no perception to alter" `showFailure` lid+        adj (Just per) = Just $ addPer (diffPer per outPer) inPer+        f = EM.alter adj lid+    modifyClient $ \cli -> cli {sfper = f (sfper cli)}++discoverKind :: MonadClient m => ItemKindIx -> m ()+discoverKind = discoverKindAndAspect++discoverKindAndAspect :: MonadClient m => ItemKindIx -> m ()+discoverKindAndAspect ix = do+  cops <- getsState scops+  -- Wipe out BFS, because the player could potentially learn that his items+  -- affect his actors' skills relevant to BFS.+  invalidateBfsAll+  side <- getsClient sside+  factionD <- getsState sfactionD+  itemToF <- getsState $ flip itemToFull+  let benefit iid = totalUsefulness cops side factionD (itemToF iid)+  itemIxMap <- getsState $ (EM.! ix) . sitemIxMap+  -- Possibly overwrite earlier, provisional benefits.+  forM_ (ES.elems itemIxMap) $ \iid -> modifyClient $ \cli ->+    cli {sdiscoBenefit = EM.insert iid (benefit iid) (sdiscoBenefit cli)}++coverKind :: ItemKindIx -> m ()+coverKind = coverAspectAndKind++coverAspectAndKind :: ItemKindIx -> m ()+coverAspectAndKind _ix = undefined++discoverAspect :: MonadClient m => ItemId -> m ()+discoverAspect iid = do+  cops <- getsState scops+  -- Wipe out BFS, because the player could potentially learn that his items+  -- affect his actors' skills relevant to BFS.+  invalidateBfsAll+  side <- getsClient sside+  factionD <- getsState sfactionD+  itemFull <- getsState $ itemToFull iid+  let benefit = totalUsefulness cops side factionD itemFull+  -- Possibly overwrite earlier, provisional benefits.+  modifyClient $ \cli ->+    cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)}++coverAspect :: ItemId -> m ()+coverAspect _iid = undefined++killExit :: MonadClient m => m ()+killExit = do+  side <- getsClient sside+  debugPossiblyPrint $ "Client" <+> tshow side <+> "quitting."+  modifyClient $ \cli -> cli {squit = True}+  -- Verify that the not saved caches are equal to future reconstructed.+  -- Otherwise, save/restore would change game state.+  sactorMaxSkills2 <- getsState sactorMaxSkills+  salter <- getsClient salter+  sbfsD <- getsClient sbfsD+  alter <- getsState createSalter+  actorMaxSkills <- getsState maxSkillsInDungeon+  let f aid = do+        (canMove, alterSkill) <- condBFS aid+        bfsArr <- createBfs canMove alterSkill aid+        let bfsPath = EM.empty+        return (aid, BfsAndPath bfsArr bfsPath)+  actorD <- getsState sactorD+  lbfsD <- mapM f $ EM.keys actorD+  -- Some freshly generated bfses are not used for comparison, but at least+  -- we check they don't violate internal assertions themselves. Hence the bang.+  let bfsD = EM.fromDistinctAscList lbfsD+      g BfsInvalid !_ = True+      g _ BfsInvalid = False+      g (BfsAndPath bfsArr1 _) (BfsAndPath bfsArr2 _) = bfsArr1 == bfsArr2+      subBfs = EM.isSubmapOfBy g+  let !_A1 = assert (salter == alter+                     `blame` "wrong accumulated salter on side"+                     `swith` (side, salter, alter)) ()+      !_A2 = assert (sactorMaxSkills2 == actorMaxSkills+                     `blame` "wrong accumulated sactorMaxSkills on side"+                     `swith` (side, sactorMaxSkills2, actorMaxSkills)) ()+      !_A3 = assert (sbfsD `subBfs` bfsD+                     `blame` "wrong accumulated sbfsD on side"+                     `swith` (side, sbfsD, bfsD)) ()+  return ()
+ engine-src/Game/LambdaHack/Client/HandleResponseM.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Semantics of responses sent by the server to clients.+module Game.LambdaHack.Client.HandleResponseM+  ( MonadClientAtomic(..), MonadClientWriteRequest(..)+  , handleResponse+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Atomic (UpdAtomic)+import Game.LambdaHack.Client.AI+import Game.LambdaHack.Client.HandleAtomicM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.Request+import Game.LambdaHack.Client.Response+import Game.LambdaHack.Client.UI+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.State++-- | Monad for executing atomic game state transformations on a client.+class MonadClient m => MonadClientAtomic m where+  -- | Execute an atomic update that changes the client's 'State'.+  execUpdAtomic :: UpdAtomic -> m ()+  -- | Put state that is intended to be the result of performing+  -- an atomic update by the server on its copy of the client's 'State'.+  execPutState :: State -> m ()++-- | Client monad in which one can send requests to the client.+class MonadClient m => MonadClientWriteRequest m where+  sendRequestAI :: RequestAI -> m ()+  sendRequestUI :: RequestUI -> m ()+  clientHasUI   :: m Bool++-- | Handle server responses.+--+-- Note that for clients communicating with the server over the net,+-- @RespUpdAtomicNoState@ should be used, because executing a single command+-- is cheaper than sending the whole state over the net.+-- However, for the standalone exe mode, with clients in the same process+-- as the server, a pointer to the state set with @execPutState@ is cheaper.+handleResponse :: ( MonadClientSetup m+                  , MonadClientUI m+                  , MonadClientAtomic m+                  , MonadClientWriteRequest m )+               => Response -> m ()+handleResponse cmd = case cmd of+  RespUpdAtomic newState cmdA -> do+    oldState <- getState+    execPutState newState+    cmdAtomicSemCli oldState cmdA+    hasUI <- clientHasUI+    when hasUI $ watchRespUpdAtomicUI cmdA+  RespUpdAtomicNoState cmdA -> do+    oldState <- getState+    execUpdAtomic cmdA+    cmdAtomicSemCli oldState cmdA+    hasUI <- clientHasUI+    when hasUI $ watchRespUpdAtomicUI cmdA+  RespQueryAI aid -> do+    cmdC <- queryAI aid+    sendRequestAI cmdC+  RespSfxAtomic sfx ->+    watchRespSfxAtomicUI sfx+  RespQueryUIunderAI -> do+    req <- queryUIunderAI+    sendRequestUI req+  RespQueryUI -> do+    -- Stop displaying the prompt, if any.+    modifySession $ \sess -> sess {sreqDelay = ReqDelayNot}+    sreqPending <- getsSession sreqPending+    req <- case sreqPending of+      Nothing -> do+        -- Server sending @RespQueryUI@ means that it's sent everything+        -- and is now ready to receive a request ASAP, so no point polling+        -- and instead query the player repeatedly until request generated.+        let loop = do+              mreq <- queryUI+              maybe loop pure mreq+        loop+      Just reqPending -> do+        modifySession $ \sess -> sess {sreqPending = Nothing}+        return reqPending+    sendRequestUI req
+ engine-src/Game/LambdaHack/Client/LoopM.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE FlexibleContexts #-}+-- | The main loop of the client, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Client.LoopM+  ( MonadClientReadResponse(..)+  , loopCli+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , initAI, initUI, loopAI, longestDelay, loopUI+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import           Data.Time.Clock+import           Data.Time.Clock.POSIX++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.HandleAtomicM+import Game.LambdaHack.Client.HandleResponseM+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.Response+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.State++-- | Client monad in which one can receive responses from the server.+class MonadClient m => MonadClientReadResponse m where+  receiveResponse :: m Response++initAI :: MonadClient m => m ()+initAI = do+  side <- getsClient sside+  debugPossiblyPrint $ "AI client" <+> tshow side <+> "initializing."++initUI :: (MonadClient m, MonadClientUI m) => CCUI -> m ()+initUI sccui@CCUI{coscreen} = do+  side <- getsClient sside+  soptions <- getsClient soptions+  debugPossiblyPrint $ "UI client" <+> tshow side <+> "initializing."+  -- Start the frontend.+  schanF <- chanFrontend coscreen soptions+  modifySession $ \sess -> sess {schanF, sccui}++-- | The main game loop for an AI or UI client. It receives responses from+-- the server, changes internal client state accordingly, analyzes+-- ensuing human or AI commands and sends resulting requests to the server.+-- Depending on whether it's an AI or UI client, it sends AI or human player+-- requests.+--+-- The loop is started in client state that is empty except for+-- the @sside@ and @seps@ fields, see 'emptyStateClient'.+loopCli :: ( MonadClientSetup m+           , MonadClientUI m+           , MonadClientAtomic m+           , MonadClientReadResponse m+           , MonadClientWriteRequest m )+        => CCUI -> UIOptions -> ClientOptions -> Bool -> m ()+loopCli ccui sUIOptions clientOptions startsNewGame = do+  modifyClient $ \cli -> cli {soptions = clientOptions}+  side <- getsClient sside+  hasUI <- clientHasUI+  if not hasUI then initAI else initUI ccui+  let cliendKindText = if not hasUI then "AI" else "UI"+  debugPossiblyPrint $ cliendKindText <+> "client"+                       <+> tshow side <+> "starting 1/4."+  -- Warning: state and client state are invalid here, e.g., sdungeon+  -- and sper are empty.+  restored <-+    if startsNewGame && not hasUI+    then return False+    else do+      restoredG <- tryRestore+      case restoredG of+        Just (cli, msess)-> do+          -- Restore game.+          case msess of+            Just sess | hasUI -> do+              -- Preserve almost everything from the saved session.+              -- Renew the communication channel to the newly spawned frontend+              -- and get the possibly updated UI content and UI options.+              schanF <- getsSession schanF+              sccui <- getsSession sccui+              putSession $ sess {schanF, sccui, sUIOptions}+            _ -> return ()+          if startsNewGame then+            -- Don't restore client state, due to new game starting right now,+            -- which means everything will be overwritten soon anyway+            -- via an @UpdRestart@ command (instead of @UpdResume@).+            return False+          else do+            -- We preserve the client state from savefile except for the single+            -- option that can be overwritten on commandline.+            let noAnim = fromMaybe False $ snoAnim $ soptions cli+            putClient cli {soptions = clientOptions {snoAnim = Just noAnim}}+            return True+        Nothing -> return False+  debugPossiblyPrint $ cliendKindText <+> "client"+                       <+> tshow side <+> "starting 2/4."+  -- At this point @ClientState@ not overriten dumbly and @State@ valid.+  tabA <- createTabBFS+  tabB <- createTabBFS+  modifyClient $ \cli -> cli {stabs = (tabA, tabB)}+  cmd1 <- receiveResponse+  debugPossiblyPrint $ cliendKindText <+> "client"+                       <+> tshow side <+> "starting 3/4."+  case (restored, startsNewGame, cmd1) of+    (True, False, RespUpdAtomic _ UpdResume{}) ->+      return ()+    (True, True, RespUpdAtomic _ UpdRestart{}) ->+      when hasUI $+        clientPrintUI "Ignoring an old savefile and starting a new game."+    (False, False, RespUpdAtomic _ UpdResume{}) ->+      error $ "Savefile of client " ++ show side ++ " not usable."+              `showFailure` ()+    (False, True, RespUpdAtomic _ UpdRestart{}) ->+      return ()+    (True, False, RespUpdAtomicNoState UpdResume{}) ->+      undefined+    (True, True, RespUpdAtomicNoState UpdRestart{}) ->+      when hasUI $+        clientPrintUI "Ignoring an old savefile and starting a new game."+    (False, False, RespUpdAtomicNoState UpdResume{}) ->+      error $ "Savefile of client " ++ show side ++ " not usable."+              `showFailure` ()+    (False, True, RespUpdAtomicNoState UpdRestart{}) ->+      return ()+    _ -> error $ "unexpected command" `showFailure` (side, restored, cmd1)+  handleResponse cmd1+  -- State and client state now valid.+  debugPossiblyPrint $ cliendKindText <+> "client"+                       <+> tshow side <+> "starting 4/4."+  if hasUI+  then loopUI 0+  else loopAI+  side2 <- getsClient sside+  debugPossiblyPrint $ cliendKindText <+> "client" <+> tshow side2+                       <+> "(initially" <+> tshow side <> ") stopped."++loopAI :: ( MonadClientSetup m+          , MonadClientUI m+          , MonadClientAtomic m+          , MonadClientReadResponse m+          , MonadClientWriteRequest m )+       => m ()+loopAI = do+  cmd <- receiveResponse+  handleResponse cmd+  quit <- getsClient squit+  unless quit+    loopAI++-- | Alarm after this many seconds without server querying us for a command.+longestDelay :: POSIXTime+longestDelay = secondsToNominalDiffTime 1+                 -- really high to accomodate slow browsers++-- | The argument is the time of last UI query from the server.+-- After @longestDelay@ seconds past this date, the client considers itself+-- ignored and displays a warning and, at a keypress, gives+-- direct control to the player, no longer waiting for the server+-- to prompt it to do so.+loopUI :: ( MonadClientSetup m+          , MonadClientUI m+          , MonadClientAtomic m+          , MonadClientReadResponse m+          , MonadClientWriteRequest m )+       => POSIXTime -> m ()+loopUI timeSinceLastQuery = do+  sreqPending <- getsSession sreqPending+  sreqDelay <- getsSession sreqDelay+  sregainControl <- getsSession sregainControl+  keyPressed <- anyKeyPressed+  let alarm = timeSinceLastQuery > longestDelay+  if | not alarm  -- no alarm starting right now+       && -- no need to mark AI for control regain ASAP:+          (sreqDelay == ReqDelayNot  -- no old alarm still in effect+           || sregainControl  -- AI control already marked for regain+           || (not keyPressed  -- player does not insist by keypress+               && sreqDelay /= ReqDelayHandled)) -> do  -- or by hack+       timeBefore <- liftIO getPOSIXTime+       cmd <- receiveResponse+       timeAfter <- liftIO getPOSIXTime+       handleResponse cmd+       -- @squit@ can be changed only in @handleResponse@, so this is the only+       -- place where it needs to be checked.+       quit <- getsClient squit+       unless quit $ case cmd of+         RespQueryUI -> loopUI 0+         RespQueryUIunderAI ->+           loopUI $ succ longestDelay  -- permit fast AI control regain+         _ -> do+           when (isJust sreqPending) $ do+             msgAdd MsgActionAlert "Warning: server updated game state after current command was issued by the client but before it was received by the server."+           -- This measures only the server's delay.+           loopUI $ timeSinceLastQuery - timeBefore + timeAfter+     | not sregainControl && (keyPressed+                              || sreqDelay == ReqDelayHandled+                              || isJust sreqPending) -> do+         -- ignore alarm if to be handled by AI control regain code elsewhere+       -- Checking for special case for UI under AI control, because the default+       -- behaviour is in this case too alarming for the player, especially+       -- during the insert coin demo before game is started.+       side <- getsClient sside+       fact <- getsState $ (EM.! side) . sfactionD+       if gunderAI fact then+         -- Mark for immediate control regain from AI.+         modifySession $ \sess -> sess {sregainControl = True}+       else do  -- should work fine even if UI faction has no leader ATM+         -- The keys mashed to make UI accessible are not considered a command.+         resetPressedKeys+         -- Stop displaying the prompt, if any, but keep UI simple.+         modifySession $ \sess -> sess {sreqDelay = ReqDelayHandled}+         let msg = if isNothing sreqPending+                   then "Server delayed asking us for a command. Regardless, UI is made accessible. Press ESC twice to listen to server some more."+                   else "Server delayed receiving a command from us. The command is cancelled. Issue a new one."+         msgAdd MsgActionAlert msg+         mreqNew <- queryUI+         msgAdd MsgPromptGeneric "Your client is listening to the server again."+         pushReportFrame+         -- TODO: once this is really used, verify that if a request+         -- overwritten, nothing breaks due to some things in our ClientState+         -- and SessionUI (but fortunately not in State nor ServerState)+         -- already set as if it was performed.+         modifySession $ \sess -> sess {sreqPending = mreqNew}+         -- Now relax completely.+         modifySession $ \sess -> sess {sreqDelay = ReqDelayNot}+       -- We may yet not know if server is ready, but perhaps server+       -- tried hard to contact us while we took control and now it sleeps+       -- for a bit, so let's give it the benefit of the doubt+       -- and a slight pause before we alarm the player again.+       loopUI 0+     | otherwise -> do+       -- We know server is not ready.+       modifySession $ \sess -> sess {sreqDelay = ReqDelayAlarm}+       -- We take a slight pause during which we display encouragement+       -- to press a key and we receive game state changes.+       -- The pause is cut short by any keypress, so it does not+       -- make UI reaction any less snappy (animations do, but that's fine).+       loopUI 0
+ engine-src/Game/LambdaHack/Client/MonadClient.hs view
@@ -0,0 +1,104 @@+-- | Basic client monad and related operations.+module Game.LambdaHack.Client.MonadClient+  ( -- * Basic client monads+    MonadClientRead ( getsClient+                    , liftIO  -- exposed only to be implemented, not used+                    )+  , MonadClient(modifyClient)+    -- * Assorted primitives+  , getClient, putClient+  , debugPossiblyPrint, createTabBFS, dumpTextFile, rndToAction+  , condInMeleeM, insertInMeleeM+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Exception as Ex+import           Control.Monad.ST.Strict (stToIO)+import qualified Control.Monad.Trans.State.Strict as St+import qualified Data.EnumSet as ES+import qualified Data.Primitive.PrimArray as PA+import qualified Data.Text.IO as T+import           System.Directory+import           System.FilePath+import           System.IO (hFlush, stdout)++import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.File+import Game.LambdaHack.Common.Kind+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Types+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Core.Random++-- | Monad for reading client state.+class MonadStateRead m => MonadClientRead m where+  getsClient :: (StateClient -> a) -> m a+  -- We do not provide a MonadIO instance, so that outside+  -- nobody can subvert the action monads by invoking arbitrary IO.+  liftIO :: IO a -> m a++-- | Monad for writing to client state.+class MonadClientRead m => MonadClient m where+  modifyClient :: (StateClient -> StateClient) -> m ()++getClient :: MonadClientRead m => m StateClient+getClient = getsClient id++putClient :: MonadClient m => StateClient -> m ()+putClient s = modifyClient (const s)++debugPossiblyPrint :: MonadClient m => Text -> m ()+debugPossiblyPrint t = do+  sdbgMsgCli <- getsClient $ sdbgMsgCli . soptions+  when sdbgMsgCli $ liftIO $ do+    T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough+    hFlush stdout++createTabBFS :: MonadClient m => m (PA.PrimArray PointI)+createTabBFS = do+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  liftIO $ stToIO $ do+    tabAMutable <- PA.newPrimArray (rWidthMax * rHeightMax)  -- always enough+    PA.unsafeFreezePrimArray tabAMutable++dumpTextFile :: MonadClientRead m => Text -> FilePath -> m FilePath+dumpTextFile t filename = liftIO $ do+  dataDir <- appDataDir+  tryCreateDir dataDir+  let path = dataDir </> filename+  Ex.handle (\(_ :: Ex.IOException) -> return ()) $+    removeFile path+  tryWriteFile path t+  return path++-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: MonadClient m => Rnd a -> m a+rndToAction r = do+  gen1 <- getsClient srandom+  let (a, gen2) = St.runState r gen1+  modifyClient $ \cli -> cli {srandom = gen2}+  return a++condInMeleeM :: MonadClientRead m => LevelId -> m Bool+condInMeleeM lid = do+  condInMelee <- getsClient scondInMelee+  return $! lid `ES.member` condInMelee++insertInMeleeM :: MonadClient m => LevelId -> m ()+insertInMeleeM lid = do+  side <- getsClient sside+  actorMaxSkills <- getsState sactorMaxSkills+  inM <- getsState $ inMelee actorMaxSkills side lid+  modifyClient $ \cli ->+--    cli {scondInMelee = ES.alterF (const inM) lid $ scondInMelee cli}+    cli {scondInMelee = if inM+                        then ES.insert lid $ scondInMelee cli+                        else ES.delete lid $ scondInMelee cli}
+ engine-src/Game/LambdaHack/Client/Preferences.hs view
@@ -0,0 +1,609 @@+-- | Actor preferences for targets and actions, based on actor aspects.+module Game.LambdaHack.Client.Preferences+  ( totalUsefulness+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , effectToBenefit+  , averageTurnValue, avgItemDelay, avgItemLife, durabilityMult+  , organBenefit, recBenefit, fakeItem+  , aspectToBenefit, capStat, aspectRecordToBenefit+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM++import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.Flavour++-- | How much AI benefits from applying the effect.+-- The first component is benefit when applied to self, the second+-- is benefit (preferably negative) when applied to enemy (via melee).+-- This represents benefit from using the effect every @avgItemDelay@ turns,+-- so if the item is not durable, the value is adjusted down elsewhere.+-- The benefit includes the drawback of having to use the actor's turn,+-- except when there is battle and item is a weapon and so there is usually+-- nothing better to do than to melee, or when the actor is stuck or idle+-- or laying in wait or luring an enemy from a safe distance.+-- So there is less than @averageTurnValue@ included in each benefit,+-- so in case when turn is not spent, e.g, periodic activation or conditions,+-- the difference in value is only slight.+effectToBenefit :: COps -> FactionId -> FactionDict -> IK.Effect+                -> (Double, Double)+effectToBenefit cops fid factionD eff =+  let delta x = (x, x)+  in case eff of+    IK.Burn d -> delta $ -(min 1000 $ 10 * Dice.meanDice d)+    IK.Explode IK.S_SINGLE_SPARK -> delta (-1)  -- probing and flavour+    IK.Explode IK.S_SPARK -> delta (-9)  -- small, to not affect weapon order+    IK.Explode IK.S_FRAGRANCE -> (1, -5)  -- situational+    IK.Explode _ ->+      -- There is a risk the explosion is focused and harmful to self+      -- or not focused and beneficial to nearby foes, but not to self.+      -- It's too costly to analyze, so we assume applying an exploding+      -- item is a bad idea and it's better to project it at foes.+      -- Due to this assumption, healing explosives should be wrapped+      -- in @OnSmash@, or else they are counted as an incentive for throwing+      -- an item at foes, which in that case is counterproductive.+      delta (-50)  -- not too low so that S_INK_SAC used by AI+    IK.RefillHP p ->+      delta $ if p > 0+              then min 2000 (20 * intToDouble p)+              else max (-1000) (10 * intToDouble p)+        -- one HP healed is worth a bit more than one HP dealt to enemy,+        -- because if the actor survives, he may deal damage many times;+        -- however, AI is mostly for non-heroes that fight in suicidal crowds,+        -- so the two values are kept close enough to maintain berserk approach+    IK.RefillCalm p ->+      ( if p > 0+        then min 100 (intToDouble p)+          -- this may cause ice to be attractive to AI,+          -- but it doesn't trigger it due to no @ConsideredByAI@+        else if p >= -5+             then max (-100) (intToDouble p)+             else max (-1500) (15 * intToDouble p)+          -- big Calm drains are incredibly dangerous, so don't be stupid+          -- and don't self-inflict them, particularly if you are an intelligent+          -- high-HP actor, which is likely if you collect and apply items+      , if p > 0+        then min 100 (intToDouble p)+        else max (-500) (5 * intToDouble p) )+          -- quite a powerful weapon, especially against high-HP foes+    IK.Dominate -> (0, -100)  -- I obtained an actor with, say 10HP,+                              -- worth 200, and enemy lost him, another 100;+                              -- divided by 3, because impression needed first+    IK.Impress -> (0, -20)  -- this causes heroes to waste a crucial resource+                            -- but makes aliens more aggresive than defensive;+                            -- also, smart use is hardcoded in AI action choice+    IK.PutToSleep -> (-10, -50)  -- can affect friends, but more often enemies+    IK.Yell -> (-1, -2)  -- usually uncontrollably wakes up enemies, so bad+    IK.Summon grp d ->  -- contrived by not checking if enemies also control+                        -- that group; safe for normal dungeon crawl content;+                        -- not correct for symmetric scenarios, but let it be+      let ben = Dice.meanDice d * 200  -- the new actor can have, say, 10HP+          fact = factionD EM.! fid+          friendlyHasGrp fid2 =+            isFriend fid fact fid2+            && fromMaybe 0 (lookup grp $ fgroups $ gkind $ factionD EM.! fid2)+               > 0+      in -- Prefer applying summoning items to flinging them; the actor gets+         -- spawned further from foes, but it's more robust.+         if any friendlyHasGrp $ EM.keys factionD+         then (ben, -1)+         else (-ben * 3, 1)  -- the foe may spawn during battle and gang up+    IK.Ascend{} -> (0, 0)+      -- only change levels sensibly, in teams, and don't remove enemy too far,+      -- he may be easy to kill and may have essential loot+    IK.Escape{} -> (-9999, 9999)  -- even if can escape, loots first and then+                                  -- handles escape as a special case+    -- The following two are expensive, because they ofen activate+    -- while in melee, in which case each turn is worth x HP, where x+    -- is the average effective weapon damage in the game, which would+    -- be ~5. (Plus a huge risk factor for any non-spawner faction.)+    -- So, each turn in battle is worth ~100. And on average, in and out+    -- of battle, let's say each turn is worth ~10.+    IK.Paralyze d -> delta $ -20 * Dice.meanDice d  -- clips+    IK.ParalyzeInWater d -> delta $ -10 * Dice.meanDice d  -- clips; resistable+    IK.InsertMove d -> delta $ 10 * Dice.meanDice d  -- turns+    IK.Teleport{} -> (-9, -1)  -- for self, don't derail exploration+                               -- for foes, fight with one less at a time+    IK.CreateItem _ COrgan IK.CONDITION _ ->+      (1, -1)  -- varied, big bunch, but try to create it anyway+    IK.CreateItem _ COrgan grp timer ->  -- assumed temporary+      let turnTimer = IK.foldTimer 1 Dice.meanDice Dice.meanDice timer+            -- copy count used instead of timer for organs with many copies+          (total, count) = organBenefit turnTimer grp cops fid factionD+      in delta $ total / intToDouble count+           -- the same when created in me and in foe+           -- average over all matching grps; simplified: rarities ignored+    IK.CreateItem _ _ IK.TREASURE _ -> (100, 0)  -- assumed not temporary+    IK.CreateItem _ _ IK.COMMON_ITEM _ -> (70, 0)+    IK.CreateItem _ _ IK.CRAWL_ITEM _ -> (70, 0)+    IK.CreateItem _ _ IK.ANY_SCROLL _ -> (50, 0)+    IK.CreateItem _ _ IK.ANY_GLASS _ -> (75, 0)+    IK.CreateItem _ _ IK.ANY_POTION _ -> (100, 0)+    IK.CreateItem _ _ IK.ANY_FLASK _ -> (50, 0)+    IK.CreateItem _ _ IK.EXPLOSIVE _ -> (50, 0)+    IK.CreateItem _ _ IK.ANY_JEWELRY _ -> (100, 0)+    IK.CreateItem _ _ grp _ ->  -- assumed not temporary and @grp@ tiny+      let (total, count) = recBenefit grp cops fid factionD+      in (total / intToDouble count, 0)+    IK.DestroyItem{} -> delta (-10)  -- potentially harmful+    IK.ConsumeItems{} -> delta (-10)  -- potentially harmful+    IK.DropItem _ _ COrgan IK.CONDITION ->+      (0, -1)  -- negative value necessary to collect such items;+               -- smart use on self is hardcoded in AI action choice+    IK.DropItem ngroup kcopy COrgan grp ->  -- assumed temporary+      -- Simplified: we assume actor has an average number of copies+      -- (and none have yet run out, e.g., prompt curing of poisoning)+      -- of a single kind of organ (and so @ngroup@ doesn't matter)+      -- of average benefit and that @kcopy@ is such that all copies+      -- are dropped. Separately we add bonuses for @ngroup@ and @kcopy@.+      -- Remaining time of the organ is arbitrarily assumed to be 20 turns.+      let turnTimer = 20+          (total, count) = organBenefit turnTimer grp cops fid factionD+          boundBonus n = if n == maxBound then 10 else 0+      in delta $ boundBonus ngroup + boundBonus kcopy+                 - total / intToDouble count+                   -- the same when dropped from me and foe+    IK.DropItem{} -> delta (-10)  -- depends a lot on what is dropped+    IK.Recharge n d -> delta $ intToDouble n * Dice.meanDice d / 10+      -- this high value to price weapons with @OnUser@ over fists+    IK.Discharge n d -> delta $ - intToDouble n * Dice.meanDice d / 10+    IK.PolyItem -> (1, 0)  -- may fizzle, so AI never uses (could loop)+    IK.RerollItem -> (1, 0)  -- may fizzle, so AI never uses (could loop)+    IK.DupItem -> (1, 0)  -- may fizzle, so AI never uses (could loop)+    IK.Identify -> (1, 0)  -- may fizzle, so AI never uses (could loop)+    IK.Detect IK.DetectAll radius -> (intToDouble radius * 2, 0)+    IK.Detect IK.DetectLoot radius -> (intToDouble radius * 2, 0)+    IK.Detect IK.DetectExit radius -> (intToDouble radius / 2, 0)+    IK.Detect _ radius -> (intToDouble radius, 0)+    IK.SendFlying _ -> (0, -1)   -- very context dependent, but lack of control+    IK.PullActor _ -> (0, -1)    -- is deadly on some maps, leading to harm;+    IK.PushActor _ -> (0, -100)  -- pushing others may crush them against wall+                                 -- and give us time to fling at them+    IK.ApplyPerfume -> delta 0  -- depends on smell sense of friends and foes+    IK.AtMostOneOf effs ->+      let bs = map (effectToBenefit cops fid factionD) effs+          f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe)+          (effSelf, effFoe) = foldr f (0, 0) bs+      in (effSelf / intToDouble (length bs), effFoe / intToDouble (length bs))+    IK.OneOf effs ->+      let bs = map (effectToBenefit cops fid factionD) effs+          f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe)+          (effSelf, effFoe) = foldr f (0, 0) bs+      in (effSelf / intToDouble (length bs), effFoe / intToDouble (length bs))+    IK.OnSmash _ -> delta 0+      -- can be beneficial; we'd need to analyze explosions, range, etc.+    IK.OnCombine eff1 -> effectToBenefit cops fid factionD eff1+    IK.OnUser eff1 ->+      let (effSelf, _) = effectToBenefit cops fid factionD eff1+      in (effSelf, - effSelf)+           -- in both cases just applies the effect to itself,+           -- which is approximately equal to applying the opposite to foe;+           -- this may result in double-counting, but ensures that weapons+           -- that harm their wielders are properly discouted;+           -- in a way, this should be double-counted, because the effect+           -- not only hinders (or enhances) applying the item,+           -- but meleeing with it, too+    IK.NopEffect -> delta 0+    IK.AndEffect eff1 _ -> effectToBenefit cops fid factionD eff1+      -- for simplicity; so in content make sure to place initial animations+      -- among normal effects, not at the start of composite effect+      -- (animations should not fail, after all), and start composite+      -- effect with the main thing+    IK.OrEffect eff1 _ -> effectToBenefit cops fid factionD eff1+    IK.SeqEffect effs -> effectToBenefits cops fid factionD effs+    IK.When _cond eff1 ->+      -- Assuming the condition met most of the time. Really, too hard for AI.+      effectToBenefit cops fid factionD eff1+    IK.Unless _cond eff1 ->+      -- Assuming the condition *not* met most of the time.+      -- Really, too hard for AI.+      effectToBenefit cops fid factionD eff1+    IK.IfThenElse _cond eff1 _eff2 ->+      -- Assuming the first is much more common. Really, too hard for AI.+      effectToBenefit cops fid factionD eff1+    IK.VerbNoLonger{} -> delta 0  -- flavour only, no benefit+    IK.VerbMsg{} -> delta 0  -- flavour only, no benefit+    IK.VerbMsgFail{} -> delta 0++effectToBenefits :: COps -> FactionId -> FactionDict -> [IK.Effect]+                 -> (Double, Double)+effectToBenefits cops fid factionD effs =+  let effPairs = map (effectToBenefit cops fid factionD) effs+      f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe)+  in foldr f (0, 0) effPairs++-- See the comment for @Paralyze@.+averageTurnValue :: Double+averageTurnValue = 10++-- Average delay between desired item uses. Some items are best activated+-- every turn, e.g., healing (but still, on average, the activation would be+-- useless some of the time, namely when HP is at max, which is rare,+-- or when some combat boost is already lasting, which is probably also rare).+-- However, e.g., for detection, activating every few turns is enough.+-- Also, sometimes actor has many activable items, so he doesn't want to use+-- the less powerful ones as often as when they are alone.+-- For weapons, it depends. Sometimes a weapon with disorienting effect+-- should be used once every couple of turns and stronger raw damage+-- weapons all the remaining time. In other cases a single weapon+-- with a devastating effect would ideally be available each turn.+-- We don't want to undervalue rarely used items with long timeouts+-- and we think that most interesting gameplay comes from alternating+-- item use, so we arbitrarily set the full value timeout to 3.+avgItemDelay :: Double+avgItemDelay = 3++-- The average time between consumable item being found+-- (and enough skill obtained to use it) and the item+-- not being worth using any more. We specifically ignore+-- item not being used any more, because it is not durable and is consumed.+-- However we do consider actor mortality (especially common for spawners)+-- and item contending with many other very different but valuable items+-- that all vie for the same turn needed to activate them (especially common+-- for non-spawners). Another reason is item getting obsolete or duplicated,+-- by finding a strictly better item or an identical item.+-- The @avgItemLife@ constant only makes sense for items with non-periodic+-- effects, because the effects' benefit is not cumulated+-- by just placing them in equipment and they cost a turn to activate.+-- We set the value to 30, assuming if the actor finds an item, then he is+-- most likely at an unlooted level, so he will find more loot soon,+-- or he is in a battle, so he will die soon (or win even more loot).+avgItemLife :: Double+avgItemLife = 30++-- The value of durable item is this many times higher than non-durable,+-- because the item will on average be activated this many times+-- before it stops being used.+durabilityMult :: Double+durabilityMult = avgItemLife / avgItemDelay++-- We assume the organ is temporary (@Fragile@ and @Periodic@)+-- and also that it doesn't provide any functionality,+-- e.g., detection or raw damage. However, we take into account effects+-- knowing in some temporary organs, e.g., poison or regeneration,+-- they are triggered at each item copy destruction. They are applied to self,+-- hence we take the self component of valuation. We multiply by the count+-- of created/dropped organs, because for conditions it determines+-- how many times the effect is applied, before the last copy expires.+--+-- The temporary organs are not durable nor in infnite copies, so to give+-- continous benefit, organ has to be recreated each @turnTimer@ turns.+-- Creation takes a turn, so incurs @averageTurnValue@ cost.+-- That's how the lack of durability impacts their value, not via+-- @durabilityMult@, which however may be applied to organ creating item.+-- So, on average, maintaining the organ costs @averageTurnValue/turnTimer@.+-- So, if an item lasts @averageTurnValue@ and can be created at will, it's+-- almost as valuable as permanent. This makes sense even if the item creating+-- the organ is not durable, but the timer is huge. One may think the lack+-- of durability should be offset by the timer, but remember that average+-- item life @avgItemLife@ is rather low, so either a new item will be found+-- soon and so the long timer doesn't matter or the actor will die+-- or the gameplay context will change (e.g., out of battle) and so the effect+-- will no longer be useful.+--+-- When considering the effects, we just use their standard valuation,+-- despite them not using up actor's turn to be applied each turn,+-- because, similarly as for periodic items, we don't control when they+-- are applied and we can't stop/restart them.+--+-- We assume, only one of the timer and count mechanisms is present at once+-- (@count@ or @turnTimer@ is 1).+-- We assume no organ has effect that drops its group or creates its group;+-- otherwise we'd loop.+organBenefit :: Double -> GroupName ItemKind -> COps -> FactionId -> FactionDict+             -> (Double, Int)+organBenefit turnTimer grp cops@COps{coitem} fid factionD =+  let f (!sacc, !pacc) !p _ !kind =+        let count = Dice.meanDice (IK.icount kind)+            paspect asp =+              intToDouble p+              * count * turnTimer+                -- the aspect stays for this many turns'+               * aspectToBenefit asp+            peffect eff =+              intToDouble p+              * count+                -- this many consecutive effects will be generated, if any+              * fst (effectToBenefit cops fid factionD eff)+        in ( sacc + (sum (map paspect $ IK.iaspects kind)+                     + sum (map peffect $ IK.ieffects kind))+             - averageTurnValue  -- the cost of 1 turn spent acquiring the organ+                                 -- (or of inflexibility of periodic items)+           , pacc + p )+  in ofoldlGroup' coitem grp f (0, 0)++-- We assume no item has effect that drops its group or creates its group;+-- otherwise we'd loop.+recBenefit :: GroupName ItemKind -> COps -> FactionId -> FactionDict+           -> (Double, Int)+recBenefit grp cops@COps{coitem, coItemSpeedup} fid factionD =+  let f (!sacc, !pacc) !p !kindId !kind =+        let km = getKindMean kindId coItemSpeedup+            recPickup =+              benPickup $ totalUsefulness cops fid factionD+                                          (fakeItem kindId kind km)+        in ( sacc + Dice.meanDice (IK.icount kind) * recPickup+           , pacc + p )+  in ofoldlGroup' coitem grp f (0, 0)++fakeItem :: ContentId IK.ItemKind -> IK.ItemKind -> IA.KindMean -> ItemFull+fakeItem kindId kind km =+  let jkind    = IdentityObvious kindId+      jfid     = Nothing  -- the default+      jflavour = dummyFlavour+      itemBase = Item{..}+      itemDisco = ItemDiscoMean km+  in ItemFull itemBase kindId kind itemDisco True++-- The value of aspect bonus is supposed to be, roughly, the benefit+-- of having that bonus on actor for one turn (as if equipping didn't cost+-- any time). Comparing or adding this value later on to the benefit of one-time+-- applying the item makes sense, especially if the item is durable,+-- but even if not, as lont as I have many items relative to equipment slots.+-- If I have scarcity of items, the value should be higher, because if I apply+-- a non-durable item, it no longer benefits me, but if I wear it,+-- it can benefit me next turn also. The time cost of equipping balances this+-- to some extent, just as @durabilityMult@ and the equipment slot limit.+--+-- Value of aspects and effects is linked by some deep economic principles+-- which I'm unfortunately ignorant of. E.g., average weapon hits for 5HP,+-- so it's worth 50 per turn, so that should also be the worth per turn+-- of equpping a sword oil that doubles damage via @AddHurtMelee@.+-- Which almost matches up, since 100% effective oil is worth 100.+-- Perhaps oil is worth double (despite cap, etc.), because it's addictive+-- and raw weapon damage is not; so oil stays and old weapons get trashed.+-- However, using the weapon in combat costs 100 (the value of extra+-- battle turn). However, one turn per turn is almost free, because something+-- has to be done to move the time forward. If the oil required wasting a turn+-- to affect next strike, then we'd have two turns per turn, so the cost+-- would be real and 100% oil would not have any significant good or bad effect+-- any more, but 200% oil (if not for the cap) would still be worth it.+--+-- Anyway, that suggests that the current scaling of effect vs aspect values+-- is reasonable. What is even more important is consistency among aspects+-- so that, e.g., a shield or a torch is never equipped by AI, but oil lamp is.+-- Valuation of effects, and more precisely, more the signs than absolute+-- values, ensures that both shield and torch get auto-picked up so that+-- the human player can nevertheless equip them in very special cases.+aspectToBenefit :: IK.Aspect -> Double+aspectToBenefit asp =+  case asp of+    IK.Timeout{} -> 0+    IK.AddSkill Ability.SkMove p -> capStat (Dice.meanDice p) * 5+    IK.AddSkill Ability.SkMelee p -> capStat (Dice.meanDice p) * 5+    IK.AddSkill Ability.SkDisplace p -> capStat (Dice.meanDice p)+    IK.AddSkill Ability.SkAlter p -> capStat (Dice.meanDice p)+    IK.AddSkill Ability.SkWait p -> capStat (Dice.meanDice p)+    IK.AddSkill Ability.SkMoveItem p -> capStat (Dice.meanDice p)+    IK.AddSkill Ability.SkProject p -> capStat (Dice.meanDice p) * 2+    IK.AddSkill Ability.SkApply p -> capStat (Dice.meanDice p) * 2+    IK.AddSkill Ability.SkSwimming p -> Dice.meanDice p+    IK.AddSkill Ability.SkFlying p -> Dice.meanDice p+    IK.AddSkill Ability.SkHurtMelee p -> Dice.meanDice p  -- offence favoured+    IK.AddSkill Ability.SkArmorMelee p -> Dice.meanDice p / 4+                                              -- only partial protection+    IK.AddSkill Ability.SkArmorRanged p -> Dice.meanDice p / 4+    IK.AddSkill Ability.SkMaxHP p -> Dice.meanDice p+    IK.AddSkill Ability.SkMaxCalm p -> Dice.meanDice p / 5+    IK.AddSkill Ability.SkSpeed p -> Dice.meanDice p * 25+      -- 1 speed ~ 5% melee; times 5 for no caps, escape, pillar-dancing, etc.;+      -- OTOH, it's 1 extra turn each 20 turns, so 100/20, so 5; figures+    IK.AddSkill Ability.SkSight p -> Dice.meanDice p * 5+    IK.AddSkill Ability.SkSmell p -> Dice.meanDice p+    IK.AddSkill Ability.SkShine p -> Dice.meanDice p * 2+    IK.AddSkill Ability.SkNocto p -> Dice.meanDice p * 30+                                       -- > sight + light; stealth, slots+    IK.AddSkill Ability.SkHearing p -> Dice.meanDice p+    IK.AddSkill Ability.SkAggression _ -> 0  -- dunno+    IK.AddSkill Ability.SkOdor p -> - Dice.meanDice p / 4+      -- rarely, if big enough, determines if one is trackable+    IK.AddSkill Ability.SkDeflectRanged p -> Dice.meanDice p * 100+    IK.AddSkill Ability.SkDeflectMelee p -> Dice.meanDice p * 100+    IK.SetFlag{} -> 0+      -- valuing @UnderRanged@ and @UnderMelee@ vs retaining the charge+      -- and explicit applying is too hard, hence ignored+    IK.ELabel{} -> 0+    IK.ToThrow{} -> 0  -- counted elsewhere+    IK.PresentAs{} -> 0+    IK.EqpSlot{} -> 0+    IK.Odds{} -> 0+      -- Should be already rolled; if not, can't tell easily.+      -- In particular, any timeouts there or @Periodic@ flags+      -- would be ignored, so they should be avoided under @Odds@+      -- in not fully-identified items, because they are so crucial+      -- for evaluation.++-- We simplify, assuming stats are unlikely to be higher than 10+-- and to be affected by more than one non-organ item at a time.+capStat :: Double -> Double+capStat x = max (-10) $ min 10 x++aspectRecordToBenefit :: IA.AspectRecord -> [Double]+aspectRecordToBenefit arItem =+  map aspectToBenefit $ IA.aspectRecordToList arItem++-- | Compute the whole 'Benefit' structure, containing various facets+-- of AI item preference, for an item with the given effects and aspects.+totalUsefulness :: COps -> FactionId -> FactionDict -> ItemFull -> Benefit+totalUsefulness cops fid factionD itemFull@ItemFull{itemKind, itemSuspect} =+  let arItem = aspectRecordFull itemFull+      -- If the item is periodic, we only add effects to equipment benefit,+      -- because we assume it's in equipment and then+      -- we can't effectively apply it, because it's never recharged,+      -- because it activates as soon as recharged.+      -- We ignore the rare case of a periodic item kept in stash+      -- to be applied manually. AI is too silly to choose it and we+      -- certainly don't want AI to destroy periodic items out of silliness.+      -- We don't assign a special bonus or malus due to being periodic,+      -- because periodic items are bad in that one can't+      -- activate them at will and they take equipment space,+      -- and good in that one saves a turn, not having+      -- to manually activate them. Additionally, no weapon can be periodic,+      -- because damage would be applied to the fighter, so a large class+      -- of items with timeout is excluded from the consideration.+      -- Generally, periodic seems more helpful on items with low timeout+      -- and obviously beneficial effects, e.g., frequent periodic healing+      -- or nearby detection is better, but infrequent periodic teleportation+      -- or harmful outward explosion is worse. But the rule is not strict+      -- and also dependent on gameplay context of the moment,+      -- hence no numerical value.+      periodic = IA.checkFlag Ability.Periodic arItem+      -- Timeout between 0 and 1 means item usable each turn, so we consider+      -- it equivalent to a permanent item --- one without timeout restriction.+      -- Timeout 2 means two such items are needed to use the effect each turn,+      -- so a single such item may be worth half of the permanent value.+      -- E.g., when item heals 1 HP each turn, that's precisly the calculation.+      timeout = intToDouble $ IA.aTimeout arItem+      scalePeriodic value = value / max 1 timeout+      -- With non-periodic items, when we need to expend a turn to apply the+      -- item or, e.g., we lose the opportunity to use another weapon if we hit+      -- with this one, the loss of value due to timeout is lower.+      -- Also, by the time cooldown recharges, one of combatants is often dead+      -- or fled, so some effects are no longer useful (but 1 HP gain is).+      -- To balance all that, we consider a square root of timeout+      -- and assume we need to spend turn on other actions at least every other+      -- turn (hence @max 2@). Note that this makes AI like powerful weapons+      -- with high timeout a bit more, though it still prefers low timeouts.+      timeoutSqrt = sqrt $ max 2 timeout+      scaleTimeout v = v / timeoutSqrt+      (effSelf, effFoe) =+        effectToBenefits cops fid factionD (IK.ieffects itemKind)+      -- Durability doesn't have any numerical impact on @eqpSum,+      -- because item is never consumed by just being stored in equipment.+      -- Also no numerical impact for flinging, because we can't fling it again+      -- in the same skirmish and also enemy can pick up and fling back.+      -- Only @benMeleeAvg@ and @benApply@ are affected, regardless if the item+      -- is in equipment or not. As summands of @benPickup@ they should be+      -- impacted by durability, because picking an item to be used+      -- only once is less advantageous than when the item is durable.+      -- For deciding which item to apply or melee with, they should be+      -- impacted, because it makes more sense to use an item that is durable+      -- and save the option for using non-durable item for the future, e.g.,+      -- when both items have timeouts, starting with durable is beneficial,+      -- because it recharges while the non-durable is prepared and used.+      durable = IA.checkFlag Ability.Durable arItem+      -- For applying, we add the self part only.+      benApply = max 0 $  -- because optional; I don't need to apply+        if periodic+        then 0  -- because always in eqp and so never recharged+        else scaleTimeout (effSelf + effDice)+               -- hits self with kintetic dice too, when applying+             / if durable then 1 else durabilityMult+      -- This assumes attacker hurt skill and enemy armor skill balance+      -- and so this value doesn't need to be recomputed at each equipment+      -- change and distributing weapons among AI actors doesn't need+      -- to match each weapon to each actor's equipment. However,+      -- a bad side-effect is that if an actor has terrible hurt skill,+      -- a weapon with high dice is still used by him before a burning weapon.+      -- Unless the opponent has even more terrible armor, unlikely,+      -- the chosen weapon is definitely not the best.+      effDice = - IK.damageUsefulness itemKind+      -- For melee, we add the foe part only.+      benMelee = if periodic+                 then 0  -- because never recharged, so never ready for melee+                 else effFoe + effDice  -- @AddHurtMelee@ already in @eqpSum@+      benMeleeAvg = scaleTimeout benMelee+                    / if durable then 1 else durabilityMult+      -- Experimenting is fun, but it's better to risk foes' skin than ours,+      -- so we only buff flinging, not applying, when item not identified.+      -- It's also more gameplay fun when enemies throw at us rather than+      -- when they use items on themselves.+      benFling = min benFlingRaw $ if itemSuspect then -10 else 0+      -- If periodic, we assume the item was in equipment, so effects+      -- were activated before flinging, so when projectile hits,+      -- it's discharged, so no kintetic damage value nor effect benefit+      -- is added to @benFling@.+      -- However, if item is not periodic, we assume the item was recharged,+      -- and so all the effects are activated at projectile impact,+      -- hence their full value is added to the kinetic damage value.+      benFlingRaw = min 0 $+        if periodic then 0 else effFoe + benFlingDice+      benFlingDice | IK.idamage itemKind == 0 = 0  -- speedup+                   | otherwise = assert (v <= 0) v+       where+        -- We assume victim completely unbuffed and not blocking. If not,+        -- let's hope the actor is similarly buffed to compensate.+        hurtMult = armorHurtCalculation True (IA.aSkills arItem)+                                             Ability.zeroSkills+        dmg = Dice.meanDice $ IK.idamage itemKind+        rawDeltaHP = ceiling $ intToDouble hurtMult * xD dmg / 100+        -- For simplicity, we ignore range bonus/malus and @Lobable@.+        IK.ThrowMod{IK.throwVelocity} = IA.aToThrow arItem+        speed = speedFromWeight (IK.iweight itemKind) throwVelocity+        v = - int64ToDouble (modifyDamageBySpeed rawDeltaHP speed) * 10 / xD 1+          -- 1 damage valued at 10, just as in @damageUsefulness@+      -- If item is periodic, we factor in the self value of effects,+      -- because they are applied to self, whether the actor wants it or not.+      -- We don't add a bonus of @averageTurnValue@ to the value of periodic+      -- effects, even though they save a turn, by being auto-applied,+      -- because on the flip side, player is not in control of the precise+      -- timing of their activation and also occasionally needs to spend a turn+      -- unequipping them to prevent activation. Note also that periodic+      -- activations don't consume the item, whether it's durable or not.+      aspectBenefits = aspectRecordToBenefit arItem+      eqpBens =+        sum $ aspectBenefits ++ [scalePeriodic (effSelf + effDice) | periodic]+      -- Equipped items may incur crippling maluses via aspects (but rather+      -- not via periodic effects). Examples of crippling maluses are zeroing+      -- melee or move skills. AI can't live with those and can't+      -- value those competently against any equally enormous bonuses+      -- the item might provide to compensate and so be even considered.+      cripplingDrawback = not (null aspectBenefits)+                          && minimum aspectBenefits < -25+      eqpSum = eqpBens - if cripplingDrawback then 100 else 0+      vApplyFling = max benApply (- benFling)+      -- If a weapon heals enemy at impact, given choice, it won't be used+      -- for melee, but can be equipped anyway, for beneficial aspects.+      -- OTOH, cif it harms wearer too much, it won't be worn+      -- but still may be flung and so may be worth picking up.+      (benInEqp, benPickupRaw)+        | IA.checkFlag Ability.Meleeable arItem+            -- the flag probably known even if item not identified+          && (benMelee < 0 || itemSuspect)+          && eqpSum >= -20 =+            let vEqp = eqpSum + maximum [benApply, - benMeleeAvg, 0]+                      -- equip plus apply or melee or not+                v = if | vEqp > 0 -> vEqp+                           -- pick up to equip; melee is crucial+                       | vApplyFling > 0 -> vApplyFling+                           -- at least pick up to apply or fling, if feasible,+                           -- and equip just in case interesting effect;+                           -- will be taken off if very harmful+                       | otherwise -> vEqp+                           -- do not pick up, but if forced, the best bet+                           -- is equip anyway+            in (True, v)+        | (IA.goesIntoEqp arItem+           || IA.checkFlag Ability.Condition arItem)+                -- hack to record benefit, to use, e.g., to assign colour+          && (eqpSum > 0 || itemSuspect) =  -- weapon or other equippable+          ( True  -- equip; long time bonus usually outweighs fling or apply+          , eqpSum  -- possibly spent turn equipping, so reap the benefits+            + if durable+              then benApply  -- apply or not but don't fling+              else 0)  -- don't remove from equipment by using up+        | otherwise = (False, vApplyFling)  -- apply or fling+      benPickupRaw2 = max benPickupRaw $ if itemSuspect then 10 else 0+      -- If periodic, pick up to deny to foes and sometimes to apply+      -- to activate the first effect only (easier than computing if the first+      -- effect is really beneficial, while all effects detrimental).+      benPickup = if periodic then max 1 benPickupRaw2 else benPickupRaw2+  in Benefit{..}
+ engine-src/Game/LambdaHack/Client/Request.hs view
@@ -0,0 +1,59 @@+-- | Abstract syntax of requests.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Client.Request+  ( RequestAI, ReqAI(..), RequestUI, ReqUI(..), RequestTimed(..)+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | Requests sent by AI clients to the server. If faction leader is to be+-- changed, it's included as the second component.+type RequestAI = (ReqAI, Maybe ActorId)++-- | Possible forms of requests sent by AI clients.+data ReqAI =+    ReqAINop+  | ReqAITimed RequestTimed+  deriving Show++-- | Requests sent by UI clients to the server. If faction leader is to be+-- changed, it's included as the second component.+type RequestUI = (ReqUI, Maybe ActorId)++-- | Possible forms of requests sent by UI clients.+data ReqUI =+    ReqUINop+  | ReqUITimed RequestTimed+  | ReqUIGameRestart (GroupName ModeKind) Challenge+  | ReqUIGameDropAndExit+  | ReqUIGameSaveAndExit+  | ReqUIGameSave+  | ReqUIDoctrine Ability.Doctrine+  | ReqUIAutomate+  deriving Show++-- | Requests that take game time.+data RequestTimed =+    ReqMove Vector+  | ReqMelee ActorId ItemId CStore+  | ReqDisplace ActorId+  | ReqAlter Point+  | ReqWait+  | ReqWait10+  | ReqYell+  | ReqMoveItems [(ItemId, Int, CStore, CStore)]+  | ReqProject Point Int ItemId CStore+  | ReqApply ItemId CStore+  deriving Show
+ engine-src/Game/LambdaHack/Client/Response.hs view
@@ -0,0 +1,35 @@+-- | Abstract syntax of responses.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Client.Response+  ( Response(..)+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Types++-- | Abstract syntax of responses sent by server to an AI or UI client+-- (or a universal client that can handle both roles, which is why+-- this type is not separated into distinct AI and UI types).+-- A response tells a client how to update game state or what information+-- to send to the server.+data Response =+    RespUpdAtomicNoState UpdAtomic+    -- ^ change @State@ by performing this atomic update+  | RespUpdAtomic State UpdAtomic+    -- ^ put the given @State@, which results from performing the atomic update+  | RespQueryAI ActorId+    -- ^ compute an AI move for the actor and send (the semantics of) it+  | RespSfxAtomic SfxAtomic+    -- ^ perform special effects (animations, messages, etc.)+  | RespQueryUIunderAI+    -- ^ check if the UI client wants to regain control+  | RespQueryUI+    -- ^ prompt the human player for a command and send (the semantics of) it+  deriving Show
+ engine-src/Game/LambdaHack/Client/State.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Client-specific game state components.+module Game.LambdaHack.Client.State+  ( StateClient(..), AlterLid, BfsAndPath(..)+  , TgtAndPath(..), Target(..), TGoal(..)+  , emptyStateClient, cycleMarkSuspect+  , updateTarget, getTarget, updateLeader, sside, sleader+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Primitive.PrimArray as PA+import           GHC.Generics (Generic)+import qualified System.Random.SplitMix32 as SM++import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector++-- | Client state, belonging to a single faction.+data StateClient = StateClient+  { seps          :: Int            -- ^ a parameter of the aiming digital line+  , stargetD      :: EM.EnumMap ActorId TgtAndPath+      -- ^ targets of our actors in the dungeon; this is only useful for AI+      --   and for directing non-pointmen, in particular with following+      --   doctrines, where non-pointmen go to the pointman's target+  , sfleeD        :: EM.EnumMap ActorId (Point, Time)+                                    -- ^ the position and time of last fleeing+                                    --   attempt (regardless if succeeded)+  , sexplored     :: ES.EnumSet LevelId+                                    -- ^ the set of fully explored levels+  , sbfsD         :: EM.EnumMap ActorId BfsAndPath+                                    -- ^ pathfinding data for our actors+  , sundo         :: () -- [CmdAtomic] -- ^ atomic commands performed to date+  , sdiscoBenefit :: DiscoveryBenefit+      -- ^ remembered AI benefits of items; could be recomputed at resume,+      --   but they are costly to generate and not too large+  , sfper         :: PerLid         -- ^ faction perception indexed by level+  , salter        :: AlterLid       -- ^ cached alter skill data for positions+                                    --   (actually, @Tile.alterMinWalk@ instead)+  , srandom       :: SM.SMGen       -- ^ current random generator+  , _sleader      :: Maybe ActorId  -- ^ candidate new leader of the faction;+                                    --   Faction.gleader is the old leader+  , _sside        :: FactionId      -- ^ faction controlled by the client+  , squit         :: Bool           -- ^ exit the game loop+  , scondInMelee  :: ES.EnumSet LevelId+                                    -- ^ whether we are in melee, per level+  , soptions      :: ClientOptions  -- ^ client options+  , stabs         :: (PA.PrimArray PointI, PA.PrimArray PointI)+      -- ^ Instead of a BFS queue (list) we use these two arrays,+      --   for (JS) speed. They need to be per-client distinct,+      --   because sometimes multiple clients interleave BFS computation.++    -- The three fields below only make sense for the UI faction,+    -- but can't be in SessionUI, because AI-moved actors of the UI faction+    -- require them for their action. Fortunately, being in StateClient+    -- of the UI client, these are never lost, even when a different faction+    -- becomes the UI faction.+  , scurChal      :: Challenge      -- ^ current game challenge setup+  , snxtChal      :: Challenge      -- ^ next game challenge setup+  , smarkSuspect  :: Int            -- ^ whether to mark suspect features+  }+  -- No @Show@ instance, because @stabs@ start undefined.++type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8)++-- | Pathfinding distances to all reachable positions of an actor+-- and a shortest paths to some of the positions.+data BfsAndPath =+    BfsInvalid+  | BfsAndPath (PointArray.Array BfsDistance)+               (EM.EnumMap Point AndPath)+  deriving Show++-- | Actor's target and a path to it, if any.+data TgtAndPath = TgtAndPath {tapTgt :: Target, tapPath :: Maybe AndPath}+  deriving (Show, Generic)++instance Binary TgtAndPath++-- | The type of na actor target.+data Target =+    TEnemy ActorId              -- ^ target an enemy+  | TNonEnemy ActorId           -- ^ target a friend or neutral+  | TPoint TGoal LevelId Point  -- ^ target a concrete spot+  | TVector Vector              -- ^ target position relative to actor+  deriving (Show, Eq, Generic)++instance Binary Target++-- | The goal of an actor.+data TGoal =+    TStash FactionId  -- ^ shared inventory stash of our or an enemy faction+  | TEnemyPos ActorId  -- ^ last seen position of the targeted actor+  | TEmbed ItemBag Point  -- ^ embedded item that can be triggered;+                          -- in @TPoint (TEmbed bag p) _ q@ usually @bag@ is+                          -- embbedded in @p@ and @q@ is an adjacent open tile+  | TItem ItemBag  -- ^ item lying on the ground+  | TSmell  -- ^ smell potentially left by enemies+  | TBlock  -- ^ a blocking tile to be approached (and, e.g., revealed+            --   to be walkable or altered or searched)+  | TUnknown  -- ^ an unknown tile to be explored+  | TKnown  -- ^ a known tile to be patrolled+  | THideout  -- ^ a hideout to either flee to or find a hidden enemy sniper in+  deriving (Show, Eq, Generic)++instance Binary TGoal++-- | Initial empty game client state.+emptyStateClient :: FactionId -> StateClient+emptyStateClient _sside =+  StateClient+    { seps = fromEnum _sside+    , stargetD = EM.empty+    , sfleeD = EM.empty+    , sexplored = ES.empty+    , sbfsD = EM.empty+    , sundo = ()+    , sdiscoBenefit = EM.empty+    , sfper = EM.empty+    , salter = EM.empty+    , srandom = SM.mkSMGen 42  -- will get modified in this and future games+    , _sleader = Nothing  -- no heroes yet alive+    , _sside+    , squit = False+    , scondInMelee = ES.empty+    , soptions = defClientOptions+    , stabs = (undefined, undefined)+    , scurChal = defaultChallenge+    , snxtChal = defaultChallenge+    , smarkSuspect = 1+    }++-- | Cycle the 'smarkSuspect' setting.+cycleMarkSuspect :: Int -> StateClient -> StateClient+cycleMarkSuspect delta cli =+  cli {smarkSuspect = (smarkSuspect cli + delta) `mod` 3}++-- | Update target parameters within client state.+updateTarget :: ActorId -> (Maybe Target -> Maybe Target) -> StateClient+             -> StateClient+updateTarget aid f cli =+  let f2 tp = case f $ fmap tapTgt tp of+        Nothing -> Nothing+        Just tgt -> Just $ TgtAndPath tgt Nothing  -- reset path+  in cli {stargetD = EM.alter f2 aid (stargetD cli)}++-- | Get target parameters from client state.+getTarget :: ActorId -> StateClient -> Maybe Target+getTarget aid cli = fmap tapTgt $ EM.lookup aid $ stargetD cli++-- | Update picked leader within state. Verify actor's faction.+updateLeader :: ActorId -> State -> StateClient -> StateClient+updateLeader leader s cli =+  let side1 = bfid $ getActorBody leader s+      side2 = sside cli+  in assert (side1 == side2 `blame` "enemy actor becomes our leader"+                            `swith` (side1, side2, leader, s))+     $ cli {_sleader = Just leader}++sside :: StateClient -> FactionId+sside = _sside++sleader :: StateClient -> Maybe ActorId+sleader = _sleader++instance Binary StateClient where+  put StateClient{..} = do+    put seps+    put stargetD+    put sfleeD+    put sexplored+    put sdiscoBenefit+    put (show srandom)+    put _sleader+    put _sside+    put scondInMelee+    put soptions+    put scurChal+    put snxtChal+    put smarkSuspect+#ifdef WITH_EXPENSIVE_ASSERTIONS+    put sfper+#endif+  get = do+    seps <- get+    stargetD <- get+    sfleeD <- get+    sexplored <- get+    sdiscoBenefit <- get+    g <- get+    _sleader <- get+    _sside <- get+    scondInMelee <- get+    soptions <- get+    scurChal <- get+    snxtChal <- get+    smarkSuspect <- get+    let sbfsD = EM.empty+        sundo = ()+        salter = EM.empty+        srandom = read g+        squit = False+        stabs = (undefined, undefined)+#ifndef WITH_EXPENSIVE_ASSERTIONS+        sfper = EM.empty+#else+    sfper <- get+#endif+    return $! StateClient{..}
+ engine-src/Game/LambdaHack/Client/UI.hs view
@@ -0,0 +1,224 @@+-- | Ways for the client to use player input via UI to produce server+-- requests, based on the client's view (visualized for the player)+-- of the game state.+--+-- This module is leaking quite a bit of implementation details+-- for the sake of "Game.LambdaHack.Client.LoopM". After multiplayer+-- is enabled again and the new requirements sorted out, this should be+-- redesigned and some code moved down the module hierarhy tree,+-- exposing a smaller API here.+module Game.LambdaHack.Client.UI+  ( -- * Querying the human player+    queryUI, queryUIunderAI+    -- * UI monad operations+  , MonadClientUI(..), putSession, anyKeyPressed, resetPressedKeys+    -- * UI session type+  , SessionUI(..), ReqDelay(..), emptySessionUI+    -- * Updating UI state wrt game state changes+  , watchRespUpdAtomicUI, watchRespSfxAtomicUI+    -- * Startup and initialization+  , CCUI(..)+  , UIOptions, applyUIOptions, uOverrideCmdline, mkUIOptions+    -- * Assorted operations and types+  , ChanFrontend, chanFrontend, tryRestore, clientPrintUI+  , pushReportFrame, msgAdd, MsgClassShow(..)+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , stepQueryUIwithLeader, stepQueryUI+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified Data.Text as T++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.Content.Input+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.Frontend+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.HandleHumanM+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Client.UI.UIOptionsParse+import           Game.LambdaHack.Client.UI.Watch+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Content.FactionKind++-- | Handle the move of a human player.+queryUI :: (MonadClient m, MonadClientUI m) => m (Maybe RequestUI)+queryUI = do+  sreqQueried <- getsSession sreqQueried+  let !_A = assert (not sreqQueried) ()  -- querying not nested+  modifySession $ \sess -> sess {sreqQueried = True}+  let loop = do+        mres <- stepQueryUIwithLeader+        saimMode <- getsSession saimMode+        case mres of+          Nothing | isJust saimMode -> loop  -- loop until aiming finished+          _ -> return mres+  mres <- loop+  modifySession $ \sess -> sess {sreqQueried = False}+  return mres++queryUIunderAI :: (MonadClient m, MonadClientUI m) => m RequestUI+queryUIunderAI = do+ -- Record history so the player can browse it later on.+ recordHistory+ -- As long as UI faction is under AI control, check, once per move,+ -- for immediate control regain or benchmark game stop.+ sregainControl <- getsSession sregainControl+ if sregainControl then do+   modifySession $ \sess -> sess { sregainControl = False+                                 , sreqDelay = ReqDelayNot+                                 , sreqPending = Nothing }  -- just in case+   -- The keys mashed to gain control are not considered a command.+   resetPressedKeys+   -- Menu is entered in @displayRespUpdAtomicUI@ at @UpdAutoFaction@+   -- and @stopAfter@ is canceled in @cmdAtomicSemCli@+   -- when handling the results of the request below.+   return (ReqUIAutomate, Nothing)+ else do+  stopAfterFrames <- getsClient $ sstopAfterFrames . soptions+  bench <- getsClient $ sbenchmark . soptions+  let exitCmd = if bench then ReqUIGameDropAndExit else ReqUIGameSaveAndExit+  case stopAfterFrames of+    Nothing -> do+      stopAfterSeconds <- getsClient $ sstopAfterSeconds . soptions+      case stopAfterSeconds of+        Nothing -> return (ReqUINop, Nothing)+        Just stopS -> do+          sstartPOSIX <- getsSession sstart+          exit <- elapsedSessionTimeGT sstartPOSIX stopS+          if exit then do+            tellAllClipPS+            return (exitCmd, Nothing)  -- ask server to exit+          else return (ReqUINop, Nothing)+    Just stopF -> do+      allNframes <- getsSession sallNframes+      gnframes <- getsSession snframes+      if allNframes + gnframes >= stopF then do+        tellAllClipPS+        return (exitCmd, Nothing)  -- ask server to exit+      else return (ReqUINop, Nothing)++stepQueryUIwithLeader :: (MonadClient m, MonadClientUI m)+                       => m (Maybe RequestUI)+stepQueryUIwithLeader = do+  side <- getsClient sside+  mleader <- getsState $ gleader . (EM.! side) . sfactionD+  mreq <- stepQueryUI+  case mreq of+    Nothing -> return Nothing+    Just req -> do+      mleader2 <- getsClient sleader+      -- Don't send the leader switch to the server with these commands,+      -- to avoid leader death at resume if his HP <= 0. That would violate+      -- the principle that save and reload doesn't change game state.+      let saveCmd cmd = case cmd of+            ReqUIGameDropAndExit -> True+            ReqUIGameSaveAndExit -> True+            ReqUIGameSave -> True+            _ -> False+      return $ Just (req, if mleader /= mleader2 && not (saveCmd req)+                          then mleader2+                          else Nothing)++-- | Let the human player issue commands until any command takes time.+stepQueryUI :: (MonadClient m, MonadClientUI m) => m (Maybe ReqUI)+stepQueryUI = do+  FontSetup{propFont} <- getFontSetup+  keyPressed <- anyKeyPressed+  macroFrame <- getsSession smacroFrame+  -- This message, in particular, disturbs.+  when (keyPressed && not (null (unKeyMacro (keyPending macroFrame)))) $+    msgAdd MsgActionWarning "*interrupted*"+  report <- getsSession $ newReport . shistory+  modifySession $ \sess -> sess {sreportNull = nullVisibleReport report}+  slides <- reportToSlideshowKeepHalt False []+  ovs <- case unsnocSlideshow slides of+    Nothing -> return EM.empty+    Just (allButLast, (ov, _)) ->+      if allButLast == emptySlideshow+      then do+        -- Display the only generated slide while waiting for next key.+        -- Strip the "--end-" prompt from it, by ignoring @MonoFont@.+        let ovProp = ov EM.! propFont+        return $!+          EM.singleton propFont $ if EM.size ov > 1 then ovProp else init ovProp+      else do+        -- Show, one by one, all slides, awaiting confirmation for each.+        void $ getConfirms ColorFull [K.spaceKM, K.escKM] slides+        -- Indicate that report wiped out.+        modifySession $ \sess -> sess {sreportNull = True}+        -- Display base frame at the end.+        return EM.empty+  mleader <- getsClient sleader+  case mleader of+    Nothing -> return ()+    Just leader -> do+      body <- getsState $ getActorBody leader+      lastLost <- getsSession slastLost+      if bhp body <= 0 then do+        side <- getsClient sside+        fact <- getsState $ (EM.! side) . sfactionD+        let gameOver = maybe False ((/= Camping) . stOutcome) (gquit fact)+        when (not gameOver && leader `ES.notMember` lastLost) $ do+          -- Hacky reuse of @slastLost@ for near-death spam prevention.+          modifySession $ \sess ->+            sess {slastLost = ES.insert leader lastLost}+          displayMore ColorBW "If you move, the exertion will kill you. Consider asking for first aid instead."+      else+        modifySession $ \sess -> sess {slastLost = ES.empty}+  km <- promptGetKey ColorFull ovs False []+  abortOrCmd <- do+    -- Look up the key.+    CCUI{coinput=InputContent{bcmdMap}} <- getsSession sccui+    case km `M.lookup` bcmdMap of+      Just (_, _, cmd) -> do+        modifySession $ \sess -> sess {swaitTimes = if swaitTimes sess > 0+                                                    then - swaitTimes sess+                                                    else 0}+        cmdSemInCxtOfKM km cmd+      _ -> let msgKey = "unknown command '" <> K.showKM km <> "'"+           in weaveJust <$> failWith (T.pack msgKey)+  -- GC macro stack if there are no actions left to handle,+  -- removing all unnecessary macro frames at once,+  -- but leaving the last one for user's in-game macros.+  modifySession $ \sess ->+    let (smacroFrameNew, smacroStackMew) =+          dropEmptyMacroFrames (smacroFrame sess) (smacroStack sess)+    in sess { smacroFrame = smacroFrameNew+            , smacroStack = smacroStackMew }+  -- The command was failed or successful and if the latter,+  -- possibly took some time.+  case abortOrCmd of+    Right cmdS ->+      -- Exit the loop and let other actors act. No next key needed+      -- and no report could have been generated.+      return $ Just cmdS+    Left Nothing -> return Nothing+    Left (Just err) -> do+      msgAdd MsgActionAlert $ showFailError err+      return Nothing
+ engine-src/Game/LambdaHack/Client/UI/ActorUI.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE DeriveGeneric #-}+-- | UI aspects of actors.+module Game.LambdaHack.Client.UI.ActorUI+  ( ActorUI(..), ActorDictUI+  , keySelected, partActor, partPronoun, tryFindActor, tryFindHeroK+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import           GHC.Generics (Generic)+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Definition.Color as Color++data ActorUI = ActorUI+  { bsymbol  :: Char         -- ^ individual map symbol+  , bname    :: Text         -- ^ individual name+  , bpronoun :: Text         -- ^ individual pronoun+  , bcolor   :: Color.Color  -- ^ individual map color+  }+  deriving (Show, Eq, Generic)++instance Binary ActorUI++type ActorDictUI = EM.EnumMap ActorId ActorUI++keySelected :: (ActorId, Actor, ActorUI)+            -> (Bool, Bool, Bool, Char, Color.Color, ActorId)+keySelected (aid, Actor{bhp, bwatch}, ActorUI{bsymbol, bcolor}) =+  (bhp > 0, bwatch /= WSleep, bsymbol /= '@', bsymbol, bcolor, aid)++-- | The part of speech describing the actor.+partActor :: ActorUI -> MU.Part+partActor b = MU.Text $ bname b++-- | The part of speech containing the actor's pronoun.+partPronoun :: ActorUI -> MU.Part+partPronoun b = MU.Text $ bpronoun b++tryFindActor :: State -> (ActorId -> Actor -> Bool) -> Maybe (ActorId, Actor)+tryFindActor s p = find (uncurry p) $ EM.assocs $ sactorD s++tryFindHeroK :: ActorDictUI -> FactionId -> Int -> State+             -> Maybe (ActorId, Actor)+tryFindHeroK d fid k s =+  let c | k == 0          = '@'+        | k > 0 && k < 10 = Char.intToDigit k+        | otherwise       = ' '  -- no hero with such symbol+  in tryFindActor s (\aid body ->+       maybe False ((== c) . bsymbol) (EM.lookup aid d)+       && bfid body == fid)
+ engine-src/Game/LambdaHack/Client/UI/Animation.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE TupleSections #-}+-- | Screen frames and animations.+module Game.LambdaHack.Client.UI.Animation+  ( Animation, renderAnim+  , pushAndDelay, twirlSplash, twirlSplashShort, blockHit, blockMiss, subtleHit+  , deathBody, shortDeathBody, actorX, teleport, vanish, swapPlaces, fadeout+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , blank, cSym, mapPosToOffset, mzipSingleton, mzipPairs+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Bits (xor)+import qualified Data.EnumMap.Strict as EM+import           Data.Word (Word32)++import Game.LambdaHack.Client.UI.Content.Screen+import Game.LambdaHack.Client.UI.Frame+import Game.LambdaHack.Client.UI.Overlay+import Game.LambdaHack.Client.UI.PointUI+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Core.Random+import Game.LambdaHack.Definition.Color++-- | Animation is a list of frame modifications to play one by one,+-- where each modification if a map from positions to level map symbols.+newtype Animation = Animation [OverlaySpace]+  deriving (Show, Eq)++-- | Render animations on top of a screen frame.+--+-- Located in this module to keep @Animation@ abstract.+renderAnim :: Int -> PreFrame -> Animation -> PreFrames+renderAnim width basicFrame (Animation anim) =+  let modifyFrame :: OverlaySpace -> PreFrame+      -- Overlay not truncated, because guaranteed within bounds.+      modifyFrame am = overlayFrame width am basicFrame+      modifyFrames :: OverlaySpace -> OverlaySpace -> Maybe PreFrame+      modifyFrames am amPrevious =+        if am == amPrevious then Nothing else Just $ modifyFrame am+  in Just basicFrame : zipWith modifyFrames anim ([] : anim)++blank :: Maybe AttrCharW32+blank = Nothing++cSym :: Color -> Char -> Maybe AttrCharW32+cSym color symbol = Just $ attrChar2ToW32 color symbol++mapPosToOffset :: (Point, AttrCharW32) -> (PointUI, AttrString)+mapPosToOffset (p, attr) =+  let pUI = squareToUI $ mapToSquare p+  in (pUI, [attr])++mzipSingleton :: Point -> Maybe AttrCharW32 -> OverlaySpace+mzipSingleton p1 mattr1 =+  map mapPosToOffset $+    let mzip (pos, mattr) = fmap (pos,) mattr+    in catMaybes [mzip (p1, mattr1)]++mzipPairs :: (Point, Point) -> (Maybe AttrCharW32, Maybe AttrCharW32)+          -> OverlaySpace+mzipPairs (p1, p2) (mattr1, mattr2) =+  map mapPosToOffset $+    let mzip (pos, mattr) = fmap (pos,) mattr+    in catMaybes $ if p1 /= p2+                   then [mzip (p1, mattr1), mzip (p2, mattr2)]+                   else -- If actor affects himself, show only the effect,+                        -- not the action.+                        [mzip (p1, mattr1)]++-- | Empty animation with a frame of delay, to be used to momentarily display+-- something for the player to see, e.g., the aiming line when swerving it.+-- Don't use this if there are multi-line messages on the screen,+-- because the text blinking is going to be distracting.+pushAndDelay :: Animation+pushAndDelay = Animation [[]]++-- | Attack animation. A part of it also reused for self-damage and healing.+twirlSplash :: (Point, Point) -> Color -> Color -> Animation+twirlSplash poss c1 c2 = Animation $ map (mzipPairs poss)+  [ (blank           , cSym BrCyan '&')+  , (blank           , cSym BrCyan '&')+  , (blank           , blank)+  , (cSym c1      '\\',blank)+  , (cSym c1      '|', cSym BrCyan '&')+  , (cSym c1      '%', blank)+  , (cSym c1      '/', blank)+  , (cSym c1      '-', blank)+  , (cSym c1      '\\',blank)+  , (cSym c2      '|', blank)+  , (cSym c2      '%', blank)+  ]++-- | Short attack animation.+twirlSplashShort :: (Point, Point) -> Color -> Color -> Animation+twirlSplashShort poss c1 c2 = Animation $ map (mzipPairs poss)+  [ (blank           , cSym BrCyan '&')+  , (blank           , cSym BrCyan '&')+  , (cSym c1      '\\',blank)+  , (cSym c1      '|', cSym BrCyan '&')+  , (cSym c2      '%', blank)+  ]++-- | Attack that hits through a block.+blockHit :: (Point, Point) -> Color -> Color -> Animation+blockHit poss c1 c2 = Animation $ map (mzipPairs poss)+  [ (blank           , cSym BrCyan '&')+  , (blank           , cSym BrCyan '&')+  , (blank           , blank)+  , (cSym BrBlue  '{', blank)+  , (cSym BrBlue  '{', cSym BrCyan '&')+  , (cSym BrBlue  '{', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym c1      '\\',blank)+  , (cSym c1      '|', blank)+  , (cSym c1      '/', blank)+  , (cSym c1      '-', blank)+  , (cSym c2      '\\',blank)+  , (cSym c2      '|', blank)+  , (cSym c2      '/', blank)+  ]++-- | Attack that is blocked.+blockMiss :: (Point, Point) -> Animation+blockMiss poss = Animation $ map (mzipPairs poss)+  [ (blank           , cSym BrCyan '&')+  , (blank           , cSym BrCyan '&')+  , (blank           , blank)+  , (cSym BrBlue  '{', blank)+  , (cSym BrBlue  '{', cSym BrCyan '&')+  , (cSym BrBlue  '{', blank)+  , (cSym BrBlue  '{', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym Blue    '}', blank)+  , (cSym Blue    '}', blank)+  , (cSym Blue    '}', blank)+  ]++-- | Attack that is subtle (e.g., damage dice 0).+subtleHit :: (Point, Point) -> Animation+subtleHit poss = Animation $ map (mzipPairs poss)+  [ (blank           , cSym BrCyan '&')+  , (blank           , blank)+  , (blank           , cSym BrYellow '&')+  , (cSym BrBlue  '\\',blank)+  , (blank           , cSym BrYellow '&')+  , (cSym BrBlue  '/', blank)+  , (blank           , blank)+  ]++-- | Death animation for an organic body.+deathBody :: Point -> Animation+deathBody pos = Animation $ map (mzipSingleton pos)+  [ cSym Red '%'+  , cSym Red '-'+  , cSym Red '-'+  , cSym Red '\\'+  , cSym Red '\\'+  , cSym Red '|'+  , cSym Red '|'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red ';'+  , cSym Red ';'+  ]++-- | Death animation for an organic body, short version (e.g., for enemies).+shortDeathBody :: Point -> Animation+shortDeathBody pos = Animation $ map (mzipSingleton pos)+  [ cSym Red '%'+  , cSym Red '-'+  , cSym Red '\\'+  , cSym Red '|'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red '%'+  , cSym Red ';'+  , cSym Red ','+  ]++-- | Mark actor location animation.+actorX :: Point -> Animation+actorX pos = Animation $ map (mzipSingleton pos)+  [ cSym BrMagenta 'X'+  , cSym BrMagenta 'X'+  , blank+  , blank+  ]++-- | Actor teleport animation.+teleport :: (Point, Point) -> Animation+teleport poss = Animation $ map (mzipPairs poss)+  [ (cSym BrMagenta 'o', cSym Magenta   '.')+  , (cSym BrMagenta 'O', cSym Magenta   '.')+  , (cSym Magenta   'o', cSym Magenta   'o')+  , (cSym Magenta   '.', cSym BrMagenta 'O')+  , (cSym Magenta   '.', cSym BrMagenta 'o')+  , (cSym Magenta   '.', blank)+  , (blank             , blank)+  ]++-- | Terrain feature vanishing animation.+vanish :: Point -> Animation+vanish pos = Animation $ map (mzipSingleton pos)+  [ cSym BrMagenta 'o'+  , cSym BrMagenta 'O'+  , cSym Magenta   'o'+  , cSym Magenta   '.'+  , cSym Magenta   '.'+  , blank+  ]++-- | Swap-places animation, both hostile and friendly.+swapPlaces :: (Point, Point) -> Animation+swapPlaces poss = Animation $ map (mzipPairs poss)+  [ (cSym BrMagenta 'o', cSym Magenta   'o')+  , (cSym BrMagenta 'd', cSym Magenta   'p')+  , (cSym BrMagenta '.', cSym Magenta   'p')+  , (cSym Magenta   'p', cSym Magenta   '.')+  , (cSym Magenta   'p', cSym BrMagenta 'd')+  , (cSym Magenta   'p', cSym BrMagenta 'd')+  , (cSym Magenta   'o', blank)+  , (blank             , blank)+  ]++fadeout :: ScreenContent -> Bool -> Int -> Rnd Animation+fadeout ScreenContent{rwidth, rheight} out step = do+  let xbound = rwidth - 1+      ybound = rheight - 1+      margin = (rwidth - 2 * rheight) `div` 2 - 2+      edge = EM.fromDistinctAscList $ zip [1..] ".%&%;:,."+      fadeChar :: Int -> Int -> Int -> Int -> Char+      fadeChar !r !n !x !y =+        let d = x - 2 * y+            ndy = n - d - 2 * ybound+            ndx = n + d - xbound - 1  -- @-1@ for asymmetry+            mnx = if ndy > 0 && ndx > 0+                  then min ndy ndx+                  else max ndy ndx+            v3 = (r `xor` (x * y)) `mod` 3+            k | mnx < 3 || mnx > 10 = mnx+              | (min x (xbound - x - y) + n + v3) `mod` 15 < 11+                && mnx > 6 = mnx - v3+              | (x + 3 * y + v3) `mod` 30 < 19 = mnx + 1+              | otherwise = mnx+        in EM.findWithDefault ' ' k edge+      rollFrame !n = do+        w <- randomWord32+        -- @fromIntegralWrap@ is potentially costly, but arch-independent.+        -- Also, it's fine if it wraps.+        let fadeAttr !y !x = attrChar1ToW32 $+              fadeChar ((fromIntegralWrap :: Word32 -> Int) w) n x y+            fadeLine !y =+              let x1 :: Int+                  {-# INLINE x1 #-}+                  x1 = min xbound (n - 2 * (ybound - y))+                  x2 :: Int+                  {-# INLINE x2 #-}+                  x2 = max 0 (xbound - (n - 2 * y))+              in [ (PointUI 0 y, map (fadeAttr y) [0..x1])+                 , (PointUI (2 * x2) y, map (fadeAttr y) [x2..xbound]) ]+        return $! concatMap fadeLine [0..ybound]+      fs | out = [3, 3 + step .. rwidth - margin]+         | otherwise = [rwidth - margin, rwidth - margin - step .. 1]+                       ++ [0]  -- no remnants of fadein onscreen, in case of lag+  Animation <$> mapM rollFrame fs
+ engine-src/Game/LambdaHack/Client/UI/Content/Input.hs view
@@ -0,0 +1,286 @@+-- | The type of definitions of key-command mappings to be used for the UI+-- and shorthands for specifying command triples in the content files.+module Game.LambdaHack.Client.UI.Content.Input+  ( InputContentRaw(..), InputContent(..), makeData+  , evalKeyDef+  , addCmdCategory, replaceDesc, moveItemTriple, repeatTriple, repeatLastTriple+  , mouseLMB, mouseMMB, mouseMMBMute, mouseRMB+  , goToCmd, runToAllCmd, autoexploreCmd, autoexplore25Cmd+  , aimFlingCmd, projectI, projectA, flingTs, applyIK, applyI+  , grabItems, dropItems, descIs, defaultHeroSelect, macroRun25+  , memberCycle, memberCycleLevel+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , replaceCmd, projectICmd, grabCmd, dropCmd+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Char as Char+import qualified Data.Map.Strict as M+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Definition.Defs++-- | Key-command mappings to be specified in content and used for the UI.+newtype InputContentRaw = InputContentRaw [(K.KM, CmdTriple)]++-- | Bindings and other information about human player commands.+data InputContent = InputContent+  { bcmdMap  :: M.Map K.KM CmdTriple   -- ^ binding of keys to commands+  , bcmdList :: [(K.KM, CmdTriple)]    -- ^ the properly ordered list+                                       --   of commands for the help menu+  , brevMap  :: M.Map HumanCmd [K.KM]  -- ^ and from commands to their keys+  }++-- | Create binding of keys to movement and other standard commands,+-- as well as commands defined in the config file.+makeData :: Maybe UIOptions   -- ^ UI client options+         -> InputContentRaw  -- ^ default key bindings from the content+         -> InputContent     -- ^ concrete binding+makeData muiOptions (InputContentRaw copsClient) =+  let (uCommands0, uVi0, uLeftHand0) = case muiOptions of+        Just UIOptions{uCommands, uVi, uLeftHand} -> (uCommands, uVi, uLeftHand)+        Nothing -> ([], True, True)+      waitTriple = ([CmdMove], "", Wait)+      wait10Triple = ([CmdMove], "", Wait10)+      moveXhairOr n cmd v = ByAimMode $ AimModeCmd { exploration = cmd v+                                                   , aiming = MoveXhair v n }+      rawContent = copsClient ++ uCommands0+      movementDefinitions =+        K.moveBinding uVi0 uLeftHand0+          (\v -> ([CmdMove], "", moveXhairOr 1 MoveDir v))+          (\v -> ([CmdMove], "", moveXhairOr 10 RunDir v))+        ++ [ (K.mkKM "KP_Begin", waitTriple)+           , (K.mkKM "C-KP_Begin", wait10Triple)+           , (K.mkKM "KP_5", wait10Triple)+           , (K.mkKM "S-KP_5", wait10Triple)  -- rxvt+           , (K.mkKM "C-KP_5", wait10Triple) ]+        ++ [(K.mkKM "period", waitTriple) | uVi0]+        ++ [(K.mkKM "C-period", wait10Triple) | uVi0]+        ++ [(K.mkKM "s", waitTriple) | uLeftHand0]+        ++ [(K.mkKM "S", wait10Triple) | uLeftHand0]+      -- This is the most common case of duplicate keys and it usually+      -- has an easy solution, so it's tested for first.+      !_A = flip assert () $+        let movementKeys = map fst movementDefinitions+            filteredNoMovement = filter (\(k, _) -> k `notElem` movementKeys)+                                        rawContent+        in rawContent == filteredNoMovement+           `blame` "commands overwrite the enabled movement keys (you can disable some in config file and try again)"+           `swith` rawContent \\ filteredNoMovement+      bcmdList = rawContent ++ movementDefinitions+      -- This catches repetitions (usually) not involving movement keys.+      rejectRepetitions _ t1 (_, "", _) = t1+      rejectRepetitions _ (_, "", _) t2 = t2+      rejectRepetitions k t1 t2 =+        error $ "duplicate key among command definitions (you can instead disable some movement key sets in config file and overwrite the freed keys)" `showFailure` (k, t1, t2)+  in InputContent+  { bcmdMap = M.fromListWithKey rejectRepetitions bcmdList+  , bcmdList+  , brevMap = M.fromListWith (flip (++)) $ concat+      [ [(cmd, [k])]+      | (k, (cats, _desc, cmd)) <- bcmdList+      , not (null cats)+        && CmdDebug `notElem` cats+      ]+  }++evalKeyDef :: (String, CmdTriple) -> (K.KM, CmdTriple)+evalKeyDef (t, triple@(cats, _, _)) =+  let km = if CmdInternal `elem` cats+           then K.KM K.NoModifier $ K.Unknown t+           else K.mkKM t+  in (km, triple)++addCmdCategory :: CmdCategory -> CmdTriple -> CmdTriple+addCmdCategory cat (cats, desc, cmd) = (cat : cats, desc, cmd)++replaceDesc :: Text -> CmdTriple -> CmdTriple+replaceDesc desc (cats, _, cmd) = (cats, desc, cmd)++replaceCmd :: HumanCmd -> CmdTriple -> CmdTriple+replaceCmd cmd (cats, desc, _) = (cats, desc, cmd)++moveItemTriple :: [CStore] -> CStore -> MU.Part -> Bool -> CmdTriple+moveItemTriple stores1 store2 object auto =+  let verb = MU.Text $ verbCStore store2+      desc = makePhrase [verb, object]+  in ([CmdItemMenu, CmdItem], desc, MoveItem stores1 store2 Nothing auto)++repeatTriple :: Int -> [CmdCategory] -> CmdTriple+repeatTriple n cats =+  ( cats+  , if n == 1+    then "voice recorded macro again"+    else "voice recorded macro" <+> tshow n <+> "times"+  , Repeat n )++repeatLastTriple :: Int -> [CmdCategory] -> CmdTriple+repeatLastTriple n cats =+  ( cats+  , if n == 1+    then "voice last action again"+    else "voice last action" <+> tshow n <+> "times in a row"+  , RepeatLast n )++-- @AimFloor@ is not there, but @AimEnemy@ and @AimItem@ almost make up for it.+mouseLMB :: HumanCmd -> Text -> CmdTriple+mouseLMB goToOrRunTo desc =+  ([CmdMouse], desc, ByAimMode aimMode)+ where+  aimMode = AimModeCmd+    { exploration = ByArea $ common ++  -- exploration mode+        [ (CaMapLeader, grabCmd)+        , (CaMapParty, PickLeaderWithPointer)+        , (CaMap, goToOrRunTo)+        , (CaArenaName, Dashboard)+        , (CaPercentSeen, autoexploreCmd) ]+    , aiming = ByArea $ common ++  -- aiming mode+        [ (CaMap, aimFlingCmd)+        , (CaArenaName, Accept)+        , (CaPercentSeen, XhairStair True) ] }+  common =+    [ (CaMessage, AllHistory)+    , (CaLevelNumber, AimAscend 1)+    , (CaXhairDesc, AimEnemy)  -- inits aiming and then cycles enemies+    , (CaSelected, PickLeaderWithPointer)+--    , (CaCalmGauge, Macro ["KP_Begin", "C-v"])+    , (CaCalmValue, Yell)+    , (CaHPGauge, Macro ["KP_Begin", "C-v"])+    , (CaHPValue, Wait)+    , (CaLeaderDesc, projectICmd flingTs) ]++mouseMMB :: CmdTriple+mouseMMB = ( [CmdMouse]+           , "snap crosshair to floor under pointer/cycle detail level"+           , XhairPointerFloor )++mouseMMBMute :: CmdTriple+mouseMMBMute = ([CmdMouse], "", XhairPointerMute)++mouseRMB :: CmdTriple+mouseRMB = ( [CmdMouse]+           , "start aiming at enemy under pointer/cycle detail level"+           , ByAimMode aimMode )+ where+  aimMode = AimModeCmd+    { exploration = ByArea $ common +++        [ (CaMapLeader, dropCmd)+        , (CaMapParty, SelectWithPointer)+        , (CaMap, AimPointerEnemy)+        , (CaArenaName, ExecuteIfClear MainMenuAutoOff)+        , (CaPercentSeen, autoexplore25Cmd) ]+    , aiming = ByArea $ common +++        [ (CaMap, XhairPointerEnemy)  -- hack; same effect, but matches LMB+        , (CaArenaName, Cancel)+        , (CaPercentSeen, XhairStair False) ] }+  common =+    [ (CaMessage, Hint)+    , (CaLevelNumber, AimAscend (-1))+    , (CaXhairDesc, AimItem)+    , (CaSelected, SelectWithPointer)+--    , (CaCalmGauge, Macro ["C-KP_Begin", "A-v"])+    , (CaCalmValue, Yell)+    , (CaHPGauge, Macro ["C-KP_Begin", "A-v"])+    , (CaHPValue, Wait10)+    , (CaLeaderDesc, ComposeUnlessError ClearTargetIfItemClear ItemClear) ]++-- This is duplicated wrt content, instead of included via @semicolon@,+-- because the C- commands are less likely to be modified by the player+-- and so more dependable than @semicolon@, @colon@, etc.+goToCmd :: HumanCmd+goToCmd = Macro ["A-MiddleButtonRelease", "C-semicolon", "C-quotedbl", "C-v"]++-- This is duplicated wrt content, instead of included via @colon@,+-- because the C- commands are less likely to be modified by the player+-- and so more dependable than @semicolon@, @colon@, etc.+runToAllCmd :: HumanCmd+runToAllCmd = Macro ["A-MiddleButtonRelease", "C-colon", "C-quotedbl", "C-v"]++autoexploreCmd :: HumanCmd+autoexploreCmd = Macro ["C-?", "C-quotedbl", "C-v"]++autoexplore25Cmd :: HumanCmd+autoexplore25Cmd = Macro ["'", "C-?", "C-quotedbl", "'", "C-V"]++aimFlingCmd :: HumanCmd+aimFlingCmd = ComposeIfLocal AimPointerEnemy (projectICmd flingTs)++projectICmd :: [TriggerItem] -> HumanCmd+projectICmd ts = ComposeUnlessError (ChooseItemProject ts) Project++projectI :: [TriggerItem] -> CmdTriple+projectI ts = ([CmdItem], descIs ts, projectICmd ts)++projectA :: [TriggerItem] -> CmdTriple+projectA ts =+  let fling = Compose2ndLocal Project ItemClear+      flingICmd = ComposeUnlessError (ChooseItemProject ts) fling+  in replaceCmd (ByAimMode AimModeCmd { exploration = AimTgt+                                      , aiming = flingICmd })+                (projectI ts)++-- | flingTs - list containing one flingable projectile+-- >>> flingTs+-- [TriggerItem {tiverb = Text "fling", tiobject = Text "in-range projectile", tisymbols = ""}]+--+-- I question the value of that test. But would Bob Martin like it+-- on the grounds it's like double-bookkeeping?+flingTs :: [TriggerItem]+flingTs = [TriggerItem { tiverb = "fling"+                       , tiobject = "in-range projectile"+                       , tisymbols = [] }]++applyIK :: [TriggerItem] -> CmdTriple+applyIK ts =+  ([CmdItem], descIs ts, ComposeUnlessError (ChooseItemApply ts) Apply)++applyI :: [TriggerItem] -> CmdTriple+applyI ts =+  let apply = Compose2ndLocal Apply ItemClear+  in ([CmdItem], descIs ts, ComposeUnlessError (ChooseItemApply ts) apply)++grabCmd :: HumanCmd+grabCmd = MoveItem [CGround] CStash (Just "grab") True+            -- @CStash@ is the implicit default; refined in HandleHumanGlobalM++grabItems :: Text -> CmdTriple+grabItems t = ([CmdItemMenu, CmdItem], t, grabCmd)++dropCmd :: HumanCmd+dropCmd = MoveItem [CStash, CEqp] CGround Nothing False++dropItems :: Text -> CmdTriple+dropItems t = ([CmdItemMenu, CmdItem], t, dropCmd)++descIs :: [TriggerItem] -> Text+descIs [] = "trigger an item"+descIs (t : _) = makePhrase [tiverb t, tiobject t]++defaultHeroSelect :: Int -> (String, CmdTriple)+defaultHeroSelect k = ([Char.intToDigit k], ([CmdMeta], "", PickLeader k))++macroRun25 :: [String]+macroRun25 = ["C-comma", "C-v"]++memberCycle :: Direction -> [CmdCategory] -> CmdTriple+memberCycle d cats = ( cats+                     , "cycle"+                       <+> (if d == Backward then "backwards" else "")+                       <+> "among all party members"+                     , PointmanCycle d )++memberCycleLevel :: Direction -> [CmdCategory] -> CmdTriple+memberCycleLevel d cats = ( cats+                          , "cycle"+                            <+> (if d == Backward then "backwards" else "")+                            <+> " among party members on the level"+                          , PointmanCycleLevel d )
+ engine-src/Game/LambdaHack/Client/UI/Content/Screen.hs view
@@ -0,0 +1,83 @@+-- | The type of definitions of screen layout and features.+module Game.LambdaHack.Client.UI.Content.Screen+  ( ScreenContent(..), emptyScreenContent, makeData+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , emptyScreenContentRaw, validateSingle+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.ByteString as BS+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T++import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.RuleKind as RK+import           Game.LambdaHack.Definition.Defs++-- | Screen layout and features definition.+--+-- Warning: this type is not abstract, but its values should not be+-- created ad hoc, even for unit tests, but should be constructed+-- with @makeData@, which includes validation,+--+-- The @emptyScreenContent@ is one such valid by construction value+-- of this type. It's suitable for bootstrapping and for testing.+data ScreenContent = ScreenContent+  { rwidth        :: X         -- ^ screen width+  , rheight       :: Y         -- ^ screen height+  , rwebAddress   :: String    -- ^ an extra blurb line for the main menu+  , rintroScreen  :: ([String], [[String]])+                               -- ^ the intro screen (first help screen) text+                               --   and the rest of the manual+  , rapplyVerbMap :: EM.EnumMap (ContentSymbol ItemKind) T.Text+                               -- ^ verbs to use for apply actions+  , rFontFiles    :: [(FilePath, BS.ByteString)]+                               -- ^ embedded game-supplied font files+  }++emptyScreenContentRaw :: ScreenContent+emptyScreenContentRaw = ScreenContent { rwidth = 5+                                      , rheight = 5+                                      , rwebAddress = ""+                                      , rintroScreen = ([], [])+                                      , rapplyVerbMap = EM.empty+                                      , rFontFiles = []+                                      }++emptyScreenContent :: ScreenContent+emptyScreenContent =+  assert (null $ validateSingle RK.emptyRuleContent emptyScreenContentRaw)+         emptyScreenContentRaw++-- | Catch invalid rule kind definitions.+validateSingle :: RK.RuleContent -> ScreenContent -> [Text]+validateSingle corule ScreenContent{..} =+  (let tsGt80 = filter ((> 80) . T.length) $ map T.pack [rwebAddress]+   in case tsGt80 of+      [] -> []+      tGt80 : _ -> ["rwebAddress's length is over 80:" <> tGt80])+  ++ (let tsGt41 = filter ((> 41) . T.length) $ map T.pack $ fst rintroScreen+      in case tsGt41 of+         [] -> []+         tGt41 : _ -> ["intro screen has a line with length over 41:" <> tGt41])+  ++ (let tsGt80 = filter ((> 80) . T.length) $ map T.pack $ intercalate [""]+                   $ snd rintroScreen+      in case tsGt80 of+         [] -> []+         tGt80 : _ -> ["manual has a line with length over 80:" <> tGt80])+  -- The following reflect the only current UI implementation.+  ++ [ "rwidth /= RK.rWidthMax" | rwidth /= RK.rWidthMax corule ]+  ++ [ "rheight /= RK.rHeightMax + 3" | rheight /= RK.rHeightMax corule + 3]++makeData :: RK.RuleContent -> ScreenContent -> ScreenContent+makeData corule sc =+  let singleOffenders = validateSingle corule sc+  in assert (null singleOffenders+             `blame` "Screen Content not valid"+             `swith` singleOffenders)+     sc
+ engine-src/Game/LambdaHack/Client/UI/ContentClientUI.hs view
@@ -0,0 +1,23 @@+-- | General content types and operations.+module Game.LambdaHack.Client.UI.ContentClientUI+  ( CCUI(..), emptyCCUI+  ) where++import Prelude ()++import qualified Data.Map.Strict as M++import Game.LambdaHack.Client.UI.Content.Input+import Game.LambdaHack.Client.UI.Content.Screen++-- | Operations for all UI content types, gathered together.+data CCUI = CCUI+  { coinput  :: InputContent+  , coscreen :: ScreenContent+  }++emptyCCUI :: CCUI+emptyCCUI = CCUI+  { coinput = InputContent M.empty [] M.empty+  , coscreen = emptyScreenContent+  }
+ engine-src/Game/LambdaHack/Client/UI/DrawM.hs view
@@ -0,0 +1,851 @@+-- {-# OPTIONS_GHC -fprof-auto #-}+-- | Display game data on the screen using one of the available frontends+-- (determined at compile time with cabal flags).+module Game.LambdaHack.Client.UI.DrawM+  ( targetDesc, targetDescXhair, drawHudFrame+  , checkWarningHP, checkWarningCalm+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , drawFrameTerrain, drawFrameContent+  , drawFramePath, drawFrameActor, drawFrameExtra, drawFrameStatus+  , drawArenaStatus, drawLeaderStatus, drawLeaderDamage, drawSelected+  , checkWarnings+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Monad.ST.Strict+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Int (Int64)+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS+import qualified Data.Text as T+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import           Data.Word (Word16, Word32)+import           GHC.Exts (inline)+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.Frontend (frontendName)+import           Game.LambdaHack.Client.UI.ItemDescription+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.CaveKind (cname)+import qualified Game.LambdaHack.Content.FactionKind as FK+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs+import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal++targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text)+targetDesc mtarget = do+  arena <- getArenaUI+  lidV <- viewedLevelUI+  mleader <- getsClient sleader+  let describeActorTarget aid = do+        side <- getsClient sside+        b <- getsState $ getActorBody aid+        bUI <- getsSession $ getActorUI aid+        actorMaxSk <- getsState $ getActorMaxSkills aid+        let percentage =+             100 * bhp b+              `div` xM (max 5 $ Ability.getSk Ability.SkMaxHP actorMaxSk)+            chs n = "[" <> T.replicate (4 - n) "_"+                        <> T.replicate n "*" <> "]"+            stars = chs $ fromEnum $ max 0 $ min 4 $ percentage `div` 20+            hpIndicator = if bfid b == side then Nothing else Just stars+        return (Just $ bname bUI, hpIndicator)+  case mtarget of+    Just (TEnemy aid) -> describeActorTarget aid+    Just (TNonEnemy aid) -> describeActorTarget aid+    Just (TPoint tgoal lid p) -> case tgoal of+      TEnemyPos{} -> do+        let hotText = if lid == lidV && arena == lidV+                      then "hot spot" <+> tshow p+                      else "a hot spot on level" <+> tshow (abs $ fromEnum lid)+        return (Just hotText, Nothing)+      _ -> do  -- the other goals can be invalidated by now anyway and it's+               -- better to say what there is rather than what there isn't+        pointedText <-+          if lid == lidV && arena == lidV+          then do+            bag <- getsState $ getFloorBag lid p+            case EM.assocs bag of+              [] -> return $! "spot" <+> tshow p+              [(iid, kit@(k, _))] -> do+                localTime <- getsState $ getLocalTime lid+                itemFull <- getsState $ itemToFull iid+                side <- getsClient sside+                factionD <- getsState sfactionD+                CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+                let (name, powers) =+                      partItem rwidth side factionD localTime itemFull kit+                return $! makePhrase [MU.Car1Ws k name, powers]+              _ -> return $! "many items at" <+> tshow p+          else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid)+        return (Just pointedText, Nothing)+    Just TVector{} -> do+      mtgtPos <- getsState $ aidTgtToPos mleader lidV mtarget+      let invalidMsg = "a relative shift"+          validMsg p = "shift to" <+> tshow p+      return (Just $ maybe invalidMsg validMsg mtgtPos, Nothing)+    Nothing -> return (Nothing, Nothing)++targetDescXhair :: MonadClientUI m+                => m (Maybe Text, Maybe Text, Maybe Watchfulness)+targetDescXhair = do+  sxhair <- getsSession sxhair+  (mhairDesc, mxhairHP) <- targetDesc sxhair+  let maid = case sxhair of+        Just (TEnemy a) -> Just a+        Just (TNonEnemy a) -> Just a+        _ -> Nothing+  case maid of+    Nothing -> return (mhairDesc, mxhairHP, Nothing)+    Just aid -> do+      watchfulness <- bwatch <$> getsState (getActorBody aid)+      return (mhairDesc, mxhairHP, Just watchfulness)++drawFrameTerrain :: forall m. MonadClientUI m => LevelId -> m (U.Vector Word32)+drawFrameTerrain drawnLevelId = do+  COps{corule=RuleContent{rWidthMax}, cotile, coTileSpeedup} <- getsState scops+  StateClient{smarkSuspect} <- getClient+  -- Not @ScreenContent@, because indexing in level's data.+  Level{ltile=PointArray.Array{avector}, lembed} <- getLevel drawnLevelId+  totVisible <- totalVisible <$> getPerFid drawnLevelId+  frameStatus <- drawFrameStatus drawnLevelId+  let dis :: PointI -> ContentId TileKind -> Color.AttrCharW32+      {-# INLINE dis #-}+      dis pI tile =+        let TK.TileKind{tsymbol, tcolor, tcolor2} = okind cotile tile+            -- @smarkSuspect@ can be turned off easily, so let's overlay it+            -- over both visible and remembered tiles.+            fg :: Color.Color+            fg | smarkSuspect > 0+                 && Tile.isSuspect coTileSpeedup tile = Color.BrMagenta+               | smarkSuspect > 1+                 && Tile.isHideAs coTileSpeedup tile = Color.Magenta+               | -- Converting maps is cheaper than converting points+                 -- and this function is a bottleneck, so we hack a bit.+                 pI `IS.member` ES.enumSetToIntSet totVisible+                 -- If all embeds spent, mark it with darker colour.+                 && not (Tile.isEmbed coTileSpeedup tile+                         && pI `IM.notMember`+                              EM.enumMapToIntMap lembed) = tcolor+               | otherwise = tcolor2+        in Color.attrChar2ToW32 fg tsymbol+      g :: PointI -> Word16 -> Word32+      g !pI !tile = Color.attrCharW32 $ dis pI (DefsInternal.toContentId tile)+      caveVector :: U.Vector Word32+      caveVector = U.imap g avector+      messageVector =+        U.replicate rWidthMax (Color.attrCharW32 Color.spaceAttrW32)+      statusVector = U.fromListN (2 * rWidthMax) $ map Color.attrCharW32 frameStatus+  -- The vector package is so smart that the 3 vectors are not allocated+  -- separately at all, but written to the big vector at once.+  -- But even with double allocation it would be faster than writing+  -- to a mutable vector via @FrameForall@.+  return $ U.concat [messageVector, caveVector, statusVector]++drawFrameContent :: forall m. MonadClientUI m => LevelId -> m FrameForall+drawFrameContent drawnLevelId = do+  COps{corule=RuleContent{rWidthMax}} <- getsState scops+  SessionUI{smarkSmell} <- getSession+  -- Not @ScreenContent@, because indexing in level's data.+  Level{lsmell, ltime, lfloor} <- getLevel drawnLevelId+  itemToF <- getsState $ flip itemToFull+  let {-# INLINE viewItemBag #-}+      viewItemBag _ floorBag = case EM.toDescList floorBag of+        (iid, _kit) : _ -> viewItem $ itemToF iid+        [] -> error $ "lfloor not sparse" `showFailure` ()+      viewSmell :: PointI -> Time -> Color.AttrCharW32+      {-# INLINE viewSmell #-}+      viewSmell pI sml =+        let fg = toEnum $ pI `rem` 13 + 2+            smlt = smellTimeout `timeDeltaSubtract`+                     (sml `timeDeltaToFrom` ltime)+        in Color.attrChar2ToW32 fg (timeDeltaToDigit smellTimeout smlt)+      mapVAL :: forall a s. (PointI -> a -> Color.AttrCharW32) -> [(PointI, a)]+             -> FrameST s+      {-# INLINE mapVAL #-}+      mapVAL f l v = do+        let g :: (PointI, a) -> ST s ()+            g (!pI, !a0) = do+              let w = Color.attrCharW32 $ f pI a0+              VM.write v (pI + rWidthMax) w+        mapM_ g l+      -- We don't usually show embedded items, because normally we don't+      -- want them to clutter the display. If they are really important,+      -- the tile they reside on has special colours and changes as soon+      -- as the item disappears. In the remaining cases, the main menu+      -- UI setting for suspect terrain highlights most tiles with embeds.+      upd :: FrameForall+      upd = FrameForall $ \v -> do+        mapVAL viewItemBag (IM.assocs $ EM.enumMapToIntMap lfloor) v+        when smarkSmell $+          mapVAL viewSmell (filter ((> ltime) . snd)+                            $ IM.assocs $ EM.enumMapToIntMap lsmell) v+  return upd++drawFramePath :: forall m. MonadClientUI m+              => LevelId -> m (FrameForall, FrameForall)+drawFramePath drawnLevelId = do+ SessionUI{saimMode} <- getSession+ sreportNull <- getsSession sreportNull+ let frameForallId = FrameForall $ const $ return ()+ case saimMode of+   Just AimMode{detailLevel} | not sreportNull+                               && detailLevel /= DetailHigh+                               && detailLevel /= DetailLow -> do+     COps{corule=RuleContent{rWidthMax, rHeightMax}, coTileSpeedup}+       <- getsState scops+     StateClient{seps} <- getClient+     -- Not @ScreenContent@, because pathing in level's map.+     Level{ltile=PointArray.Array{avector}} <- getLevel drawnLevelId+     totVisible <- totalVisible <$> getPerFid drawnLevelId+     mleader <- getsClient sleader+     xhairPos <- xhairToPos+     bline <- case mleader of+       Just leader -> do+         Actor{bpos, blid} <- getsState $ getActorBody leader+         return $! if blid /= drawnLevelId+                   then []+                   else fromMaybe []+                        $ bresenhamsLineAlgorithm seps bpos xhairPos+       _ -> return []+     mpath <- maybe (return Nothing) (\aid -> do+       mtgtMPath <- getsClient $ EM.lookup aid . stargetD+       case mtgtMPath of+         Just TgtAndPath{tapPath=tapPath@(Just AndPath{pathGoal})}+           | pathGoal == xhairPos -> return tapPath+         _ -> getCachePath aid xhairPos) mleader+     assocsAtxhair <- getsState $ posToAidAssocs xhairPos drawnLevelId+     let shiftedBTrajectory = case assocsAtxhair of+           (_, Actor{btrajectory = Just p, bpos = prPos}) : _+             | detailLevel == defaultDetailLevel ->+               trajectoryToPath prPos (fst p)+           _ -> []+         shiftedLine =+           delete xhairPos+           $ takeWhile (insideP (0, 0, rWidthMax - 1, rHeightMax - 1))+           $ if null shiftedBTrajectory+             then bline+             else shiftedBTrajectory+         lpath = if not (null bline) && null shiftedBTrajectory+                 then delete xhairPos $ maybe [] pathList mpath+                 else []+         acOnPathOrLine :: Char -> Point -> ContentId TileKind+                        -> Color.AttrCharW32+         acOnPathOrLine !ch !p0 !tile =+           let fgOnPathOrLine =+                 case ( ES.member p0 totVisible+                      , Tile.isWalkable coTileSpeedup tile ) of+                   _ | isUknownSpace tile -> Color.BrBlack+                   _ | Tile.isSuspect coTileSpeedup tile -> Color.BrMagenta+                   (True, True)   -> Color.BrGreen+                   (True, False)  -> Color.BrRed+                   (False, True)  -> Color.Green+                   (False, False) -> Color.Red+           in Color.attrChar2ToW32 fgOnPathOrLine ch+         mapVTL :: forall s. (Point -> ContentId TileKind -> Color.AttrCharW32)+                -> [Point]+                -> FrameST s+         mapVTL f l v = do+           let g :: Point -> ST s ()+               g !p0 = do+                 let pI = fromEnum p0+                     tile = avector U.! pI+                     w = Color.attrCharW32+                         $ f p0 (DefsInternal.toContentId tile)+                 VM.write v (pI + rWidthMax) w+           mapM_ g l+         upd :: FrameForall+         upd = FrameForall $ \v -> do+           mapVTL (acOnPathOrLine ';') lpath v+           mapVTL (acOnPathOrLine '*') shiftedLine v  -- overwrites path+     return (upd, if null shiftedBTrajectory then frameForallId else upd)+   _ -> return (frameForallId, frameForallId)++drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall+drawFrameActor drawnLevelId = do+  COps{corule=RuleContent{rWidthMax}} <- getsState scops+  SessionUI{sactorUI, sselected, sUIOptions} <- getSession+  -- Not @ScreenContent@, because indexing in level's data.+  Level{lbig, lproj} <- getLevel drawnLevelId+  side <- getsClient sside+  s <- getState+  let {-# INLINE viewBig #-}+      viewBig aid =+          let Actor{bhp, bfid, btrunk, bwatch} = getActorBody aid s+              ActorUI{bsymbol, bcolor} = sactorUI EM.! aid+              Item{jfid} = getItemBody btrunk s+              symbol | bhp > 0 = bsymbol+                     | otherwise = '%'+              dominated = maybe False (/= bfid) jfid+              bg = if | bwatch == WSleep -> Color.HighlightBlue+                      | dominated -> if bfid == side  -- dominated by us+                                     then Color.HighlightCyan+                                     else Color.HighlightBrown+                      | ES.member aid sselected -> Color.HighlightGreen+                      | otherwise -> Color.HighlightNone+              fg | bfid /= side || bhp <= 0 = bcolor+                 | otherwise =+                let (hpCheckWarning, calmCheckWarning) =+                      checkWarnings sUIOptions aid s+                in if hpCheckWarning || calmCheckWarning+                   then Color.Red+                   else bcolor+         in Color.attrCharToW32 $ Color.AttrChar Color.Attr{..} symbol+      {-# INLINE viewProj #-}+      viewProj as = case as of+        aid : _ ->+          let ActorUI{bsymbol, bcolor} = sactorUI EM.! aid+              bg = Color.HighlightNone+              fg = bcolor+         in Color.attrCharToW32 $ Color.AttrChar Color.Attr{..} bsymbol+        [] -> error $ "lproj not sparse" `showFailure` ()+      mapVAL :: forall a s. (a -> Color.AttrCharW32) -> [(PointI, a)]+             -> FrameST s+      {-# INLINE mapVAL #-}+      mapVAL f l v = do+        let g :: (PointI, a) -> ST s ()+            g (!pI, !a0) = do+              let w = Color.attrCharW32 $ f a0+              VM.write v (pI + rWidthMax) w+        mapM_ g l+      upd :: FrameForall+      upd = FrameForall $ \v -> do+        mapVAL viewProj (IM.assocs $ EM.enumMapToIntMap lproj) v+        mapVAL viewBig (IM.assocs $ EM.enumMapToIntMap lbig) v+          -- big actor overlay projectiles+  return upd++drawFrameExtra :: forall m. MonadClientUI m+               => ColorMode -> LevelId -> m FrameForall+drawFrameExtra dm drawnLevelId = do+  -- Not @ScreenContent@, because indexing in level's data.+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  SessionUI{saimMode, smarkVision} <- getSession+  mleader <- getsClient sleader+  mbody <- getsState $ \s -> flip getActorBody s <$> mleader+  totVisible <- totalVisible <$> getPerFid drawnLevelId+  mxhairPos <- mxhairToPos+  mtgtPos <- do+    mtgt <- getsClient $ maybe (const Nothing) getTarget mleader+    getsState $ aidTgtToPos mleader drawnLevelId mtgt+  side <- getsClient sside+  factionD <- getsState sfactionD+  let visionMarks = IS.toList $ ES.enumSetToIntSet totVisible+      backlightVision :: Color.AttrChar -> Color.AttrChar+      backlightVision ac = case ac of+        Color.AttrChar (Color.Attr fg Color.HighlightNone) ch ->+          Color.AttrChar (Color.Attr fg Color.HighlightBackground) ch+        _ -> ac+      writeSquare !hi (Color.AttrChar (Color.Attr fg bg) ch) =+        let hiUnlessLeader | bg == Color.HighlightYellow = bg+                           | otherwise = hi+        in Color.AttrChar (Color.Attr fg hiUnlessLeader) ch+      turnBW (Color.AttrChar _ ch) = Color.AttrChar Color.defAttr ch+      mapVL :: forall s. (Color.AttrChar -> Color.AttrChar) -> [PointI]+            -> FrameST s+      mapVL f l v = do+        let g :: PointI -> ST s ()+            g !pI = do+              w0 <- VM.read v (pI + rWidthMax)+              let w = Color.attrCharW32 . Color.attrCharToW32+                      . f . Color.attrCharFromW32 . Color.AttrCharW32 $ w0+              VM.write v (pI + rWidthMax) w+        mapM_ g l+      -- Here @rWidthMax@ and @rHeightMax@ are correct, because we are not+      -- turning the whole screen into black&white, but only the level map.+      lDungeon = [0..rWidthMax * rHeightMax - 1]+      leaderColor = if isJust saimMode+                    then Color.HighlightYellowAim+                    else Color.HighlightYellow+      xhairColor = if isJust saimMode+                   then Color.HighlightRedAim+                   else Color.HighlightRed+      locateStash (fid, fact) = case gstash fact of+        Just (lid, pos) | lid == drawnLevelId ->+          let stashColor = if fid == side+                           then Color.HighlightWhite+                           else Color.HighlightMagenta+          in Just (pos, stashColor)+        _ -> Nothing+      stashesToDisplay = mapMaybe locateStash $ EM.assocs factionD+      upd :: FrameForall+      upd = FrameForall $ \v -> do+        when (isJust saimMode && smarkVision >= 1 || smarkVision == 2) $+          mapVL backlightVision visionMarks v+        case mtgtPos of+          Nothing -> return ()+          Just p -> mapVL (writeSquare Color.HighlightGrey) [fromEnum p] v+        mapM_ (\(pos, color) -> mapVL (writeSquare color) [fromEnum pos] v)+              stashesToDisplay+        case mbody of  -- overwrites target+          Just body | drawnLevelId == blid body ->+            mapVL (writeSquare leaderColor) [fromEnum $ bpos body] v+          _ -> return ()+        case mxhairPos of  -- overwrites target and non-aim leader box+          Nothing -> return ()+          Just p -> mapVL (writeSquare xhairColor) [fromEnum p] v+        when (dm == ColorBW) $ mapVL turnBW lDungeon v+  return upd++drawFrameStatus :: MonadClientUI m => LevelId -> m AttrString+drawFrameStatus drawnLevelId = do+  cops@COps{corule=RuleContent{rWidthMax=_rWidthMax}} <- getsState scops+  SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession+  mleader <- getsClient sleader+  mxhairPos <- mxhairToPos+  mbfs <- maybe (return Nothing) (fmap Just . getCacheBfs) mleader+  (mhairDesc, mxhairHP, mxhairWatchfulness) <- targetDescXhair+  lvl <- getLevel drawnLevelId+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  (mblid, mbpos, mbodyUI) <- case mleader of+    Just leader -> do+      Actor{bpos, blid} <- getsState $ getActorBody leader+      bodyUI <- getsSession $ getActorUI leader+      return (Just blid, Just bpos, Just bodyUI)+    Nothing -> return (Nothing, Nothing, Nothing)+  let widthX = 80+      widthTgt = 39+      widthStatus = widthX - widthTgt - 1+      arenaStatus = drawArenaStatus cops lvl widthStatus+      leaderStatusWidth = 23+  leaderStatus <- drawLeaderStatus swaitTimes+  (selectedStatusWidth, selectedStatus)+    <- drawSelected drawnLevelId (widthStatus - leaderStatusWidth) sselected+  let speedStatusWidth = widthStatus - leaderStatusWidth - selectedStatusWidth+  speedDisplay <- case mleader of+    Nothing -> return []+    Just leader -> do+      actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+      kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan]+      let speed = Ability.getSk Ability.SkSpeed actorCurAndMaxSk+          unknownBonus = unknownSpeedBonus $ map (fst . snd) kitAssRaw+          speedString = displaySpeed speed ++ if unknownBonus then "?" else ""+          conditionBonus = conditionSpeedBonus $ map snd kitAssRaw+          cspeed = case compare conditionBonus 0 of+            LT -> Color.Red+            EQ -> Color.White+            GT -> Color.Green+      return $! map (Color.attrChar2ToW32 cspeed) speedString+  let speedStatus = if length speedDisplay >= speedStatusWidth+                    then []+                    else speedDisplay ++ [Color.spaceAttrW32]+      displayPathText mp mt =+        let (plen, llen) | Just target <- mp+                         , Just bfs <- mbfs+                         , Just bpos <- mbpos+                         , mblid == Just drawnLevelId+                         = ( fromMaybe 0 (accessBfs bfs target)+                           , chessDist bpos target )+                         | otherwise = (0, 0)+            pText | plen == 0 = ""+                  | otherwise = "p" <> tshow plen+            lText | llen == 0 = ""+                  | otherwise = "l" <> tshow llen+            text = fromMaybe (pText <+> lText) mt+        in if T.null text then "" else " " <> text+      -- The indicators must fit, they are the actual information.+      pathCsr = displayPathText mxhairPos mxhairHP+      trimTgtDesc n t = assert (not (T.null t) && n > 2 `blame` (t, n)) $+        if T.length t <= n then t else T.take (n - 3) t <> "..."+      -- The indicators must fit, they are the actual information.+      widthXhairOrItem = widthTgt - T.length pathCsr+      nMember = MU.Ord $ 1 + sum (EM.elems $ gvictims fact)+      fallback = if FK.fhasPointman (gkind fact)+                 then makePhrase+                        ["Waiting for", nMember, "team member to spawn"]+                 else "This faction never picks a pointman"+      leaderName bUI = trimTgtDesc (widthTgt - 10) (bname bUI)+      leaderBlurbLong = maybe fallback (\bUI ->+        "Pointman:" <+> leaderName bUI) mbodyUI+      leaderBlurbShort = maybe fallback leaderName mbodyUI+  ours <- getsState $ fidActorNotProjGlobalAssocs side+  ns <- getsState $ EM.size . getFactionStashBag side+  let na = length ours+      nl = ES.size $ ES.fromList $ map (blid . snd) ours+      -- To be replaced by something more useful.+      teamBlurb = textToAS $ trimTgtDesc widthTgt $+        makePhrase [ "Team:"+                   , MU.CarWs na "actor", "on"+                   , MU.CarWs nl "level" <> ","+                   , "stash", MU.Car ns ]+      markSleepTgtDesc+        | mxhairWatchfulness /= Just WSleep = textToAS+        | otherwise = textFgToAS Color.cSleep+      xdetail AimMode{detailLevel} =+        "x" <> tshow (1 + fromEnum detailLevel)+      xhairName aimMode = "Crosshair" <+> xdetail aimMode+      xhairBlurb =+        maybe+          teamBlurb+          (\t -> case saimMode of+             Just aimMode ->+               textToAS (xhairName aimMode <> ":")+               <+:> markSleepTgtDesc (trimTgtDesc (widthXhairOrItem - 14) t)+             Nothing -> markSleepTgtDesc (trimTgtDesc widthXhairOrItem t))+          mhairDesc+      tgtOrItem+        | Just (iid, fromCStore, _) <- sitemSel+        , Just leader <- mleader+        = do+            b <- getsState $ getActorBody leader+            bag <- getsState $ getBodyStoreBag b fromCStore+            case iid `EM.lookup` bag of+              Nothing -> return (xhairBlurb, pathCsr)+              Just kit@(k, _) -> do+                localTime <- getsState $ getLocalTime (blid b)+                itemFull <- getsState $ itemToFull iid+                factionD <- getsState sfactionD+                CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+                let (name, powers) =+                      partItem rwidth (bfid b) factionD localTime itemFull kit+                    t = makePhrase [MU.Car1Ws k name, powers]+                    xhairHP = maybe "" (" " <>) mxhairHP+                    (xItemWidth, xItemText) = case saimMode of+                      Just aimMode -> (9, "Item" <+> xdetail aimMode)+                      Nothing -> (6, "Item")+                    trimTD =+                      trimTgtDesc (widthTgt - T.length xhairHP - xItemWidth) t+                return (textToAS $ xItemText <> ":" <+> trimTD, xhairHP)+        | otherwise =+            return (xhairBlurb, pathCsr)+  (xhairLine, pathXhairOrNull) <- tgtOrItem+  damageStatus <- maybe (return []) (drawLeaderDamage widthTgt) mleader+  let damageStatusWidth = length damageStatus+      withForLeader = widthTgt - damageStatusWidth - 1+      leaderBottom =+        if | T.length leaderBlurbShort > withForLeader -> ""+           | T.length leaderBlurbLong > withForLeader -> leaderBlurbShort+           | otherwise -> leaderBlurbLong+      damageGap = blankAttrString+                  $ widthTgt - damageStatusWidth - T.length leaderBottom+      xhairGap = blankAttrString (widthTgt - T.length pathXhairOrNull+                                         - length xhairLine)+      xhairStatus = xhairLine ++ xhairGap ++ textToAS pathXhairOrNull+      selectedGap = blankAttrString (widthStatus - leaderStatusWidth+                                               - selectedStatusWidth+                                               - length speedStatus)+      status = arenaStatus+               <> [Color.spaceAttrW32]+               <> xhairStatus+               <> selectedStatus ++ selectedGap ++ speedStatus ++ leaderStatus+               <> [Color.spaceAttrW32]+               <> (textToAS leaderBottom ++ damageGap ++ damageStatus)+  -- Keep it at least partially lazy, to avoid allocating the whole list:+  return+#ifdef WITH_EXPENSIVE_ASSERTIONS+    $ assert (length status == 2 * _rWidthMax+              `blame` attrStringToString status)+#endif+        status++-- | Draw the whole screen: level map and status area.+drawHudFrame :: MonadClientUI m => ColorMode -> LevelId -> m PreFrame+drawHudFrame dm drawnLevelId = do+  baseTerrain <- drawFrameTerrain drawnLevelId+  updContent <- drawFrameContent drawnLevelId+  (updPath, updTrajectory) <- drawFramePath drawnLevelId+  updActor <- drawFrameActor drawnLevelId+  updExtra <- drawFrameExtra dm drawnLevelId+  soptions <- getsClient soptions+  let upd = FrameForall $ \v -> do+        unFrameForall updContent v+        -- ANSI frontend is screen-reader friendly, so avoid visual fluff+        unless (frontendName soptions == "ANSI") $ unFrameForall updPath v+        unFrameForall updActor v+        unFrameForall updTrajectory v+        unFrameForall updExtra v+  return (baseTerrain, upd)++-- Comfortably accomodates 3-digit level numbers and 25-character+-- level descriptions (currently enforced max).+--+-- Sometimes the level seems fully explored, but the display shows+-- 99% or even goes from 100% to 99% at some moment.+-- This is due to monsters, e.g., clearning rubble or burning bush,+-- and so creating a new explorable terrain.+drawArenaStatus :: COps -> Level -> Int -> AttrString+drawArenaStatus COps{cocave}+                Level{lkind, ldepth=Dice.AbsDepth ld, lseen, lexpl}+                width =+  let ck = okind cocave lkind+      seenN = 100 * lseen `div` max 1 lexpl+      seenTxt | seenN >= 100 = "all"+              | otherwise = tshow seenN <> "%"+      lvlN = T.justifyLeft 2 ' ' (tshow ld)+      seenStatus = "[" <> seenTxt <+> "seen]"+  in textToAS $ T.take (width - 10)+                       (T.justifyLeft (width - 10) ' ' (lvlN <+> cname ck))+                <> T.justifyRight 10 ' ' seenStatus++drawLeaderStatus :: MonadClientUI m => Int -> m AttrString+drawLeaderStatus waitT = do+  time <- getsState stime+  let calmHeaderText = "Calm"+      hpHeaderText = "HP"+      slashes = ["/", "|", "\\", "|"]+      waitGlobal = timeFit time timeTurn+  sUIOptions <- getsSession sUIOptions+  mleader <- getsClient sleader+  case mleader of+    Just leader -> do+      b <- getsState $ getActorBody leader+      actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+      (hpCheckWarning, calmCheckWarning)+        <- getsState $ checkWarnings sUIOptions leader+      bdark <- getsState $ not . actorInAmbient b+      let showTrunc x = let t = show x+                        in if length t > 3+                           then if x > 0 then "***" else "---"+                           else t+          waitSlash | bwatch b == WSleep = waitGlobal+                    | otherwise = abs waitT+          -- This is a valuable feedback for the otherwise hard to observe+          -- 'wait' command or for passing of time when sole leader sleeps.+          slashPick = slashes !! (max 0 waitSlash `mod` length slashes)+          addColor c = map (Color.attrChar2ToW32 c)+          checkDelta ResDelta{..}+            | fst resCurrentTurn < 0 || fst resPreviousTurn < 0+              = addColor Color.BrRed  -- alarming news have priority+            | snd resCurrentTurn > 0 || snd resPreviousTurn > 0+              = addColor Color.BrGreen+            | otherwise = stringToAS  -- only if nothing at all noteworthy+          checkSleep body resDelta+            | bwatch body == WSleep = addColor Color.cSleep+            | otherwise = checkDelta resDelta+          calmAddAttr = checkSleep b $ bcalmDelta b+          -- We only show ambient light, because in fact client can't tell+          -- if a tile is lit, because it it's seen it may be due to ambient+          -- or dynamic light or due to infravision.+          darkPick | bdark = "."+                   | otherwise = ":"+          calmHeader = calmAddAttr $ calmHeaderText <> darkPick+          maxCalm = max 0 $ Ability.getSk Ability.SkMaxCalm actorCurAndMaxSk+          calmText = showTrunc (bcalm b `divUp` oneM)+                     <> (if bdark then slashPick else "/")+                     <> showTrunc maxCalm+          bracePick | actorWaits b = "}"+                    | otherwise = ":"+          hpAddAttr = checkDelta $ bhpDelta b+          hpHeader = hpAddAttr $ hpHeaderText <> bracePick+          maxHP = max 0 $ Ability.getSk Ability.SkMaxHP actorCurAndMaxSk+          hpText = showTrunc (bhp b `divUp` oneM)+                   <> (if not bdark then slashPick else "/")+                   <> showTrunc maxHP+          justifyRight n t = replicate (n - length t) ' ' ++ t+          colorWarning w enough full | w = addColor Color.Red+                                     | not enough = addColor Color.Brown+                                     | full = addColor Color.Magenta+                                     | otherwise = stringToAS+      return $! calmHeader+                <> colorWarning calmCheckWarning+                                (calmEnough b actorCurAndMaxSk)+                                (bcalm b > xM maxCalm)+                                (justifyRight 7 calmText)+                <+:> hpHeader+                <> colorWarning hpCheckWarning+                                True+                                (bhp b > xM maxHP)+                                (justifyRight 7 hpText)+    Nothing -> do+      -- This is a valuable feedback for passing of time while faction+      -- leaderless and especially while temporarily actor-less..+      let slashPick = slashes !! (max 0 waitGlobal `mod` length slashes)+      return $! stringToAS (calmHeaderText ++ ":  --" ++ slashPick ++ "--")+                <+:> stringToAS (hpHeaderText <> ":  --/--")++drawLeaderDamage :: MonadClientUI m => Int -> ActorId -> m AttrString+drawLeaderDamage width leader = do+  kitAssRaw <- getsState $ kitAssocs leader [CEqp, COrgan]+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  let unBurn (IK.Burn d) = Just d+      unBurn _ = Nothing+      unRefillHP (IK.RefillHP n) = Just n+      unRefillHP _ = Nothing+      hasNonDamagesEffect itemFull =+        any (\eff -> IK.forApplyEffect eff && not (IK.forDamageEffect eff))+            (IK.ieffects $ itemKind itemFull)+      ppDice :: Bool -> (Bool, Int, Int, ItemFullKit)+             -> [(Bool, (AttrString, AttrString))]+      ppDice showInBrief (hasEffect, timeout, ncha, (itemFull, (k, _))) =+        let dice = IK.idamage $ itemKind itemFull+            tdice = case Dice.reduceDice dice of+              Just d | showInBrief -> show d+              _ -> show dice+            -- We ignore nested effects because they are, in general, avoidable.+            -- We also ignore repeated effect kinds for HUD simplicity.+            tBurn = maybe "" (('+' :) . show)  $ listToMaybe $ mapMaybe unBurn+                                               $ IK.ieffects $ itemKind itemFull+            nRefillHP = maybe 0 (min 0) $ listToMaybe $ mapMaybe unRefillHP+                                        $ IK.ieffects $ itemKind itemFull+            tRefillHP | nRefillHP < 0 = '+' : show (- nRefillHP)+                      | otherwise = ""+            tdiceEffect = if hasEffect && hasNonDamagesEffect itemFull+                          then map Char.toUpper tdice+                          else tdice+            ldice color = map (Color.attrChar2ToW32 color) tdiceEffect+            lBurnHP charged =+              let cburn = if charged then Color.BrRed else Color.Red+                  chp = if charged then Color.BrMagenta else Color.Magenta+              in map (Color.attrChar2ToW32 cburn) tBurn+                 ++ map (Color.attrChar2ToW32 chp) tRefillHP+            possiblyHasTimeout = timeout > 0 || itemSuspect itemFull+        in if possiblyHasTimeout+           then replicate (k - ncha)+                          (False, (ldice Color.Cyan, lBurnHP False))+                ++ replicate ncha (True, (ldice Color.BrCyan, lBurnHP True))+           else [(True, (ldice Color.BrBlue, lBurnHP True))]+      lbonus :: AttrString+      lbonus =+        let bonusRaw = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk+            bonus = min 200 $ max (-200) bonusRaw+            unknownBonus = unknownMeleeBonus $ map (fst . snd) kitAssRaw+            tbonus = if bonus == 0+                     then if unknownBonus then "+?" else ""+                     else (if bonus > 0 then "+" else "")+                          <> show bonus+                          <> (if bonus /= bonusRaw then "$" else "")+                          <> if unknownBonus then "%?" else "%"+            conditionBonus = conditionMeleeBonus $ map snd kitAssRaw+            cbonus = case compare conditionBonus 0 of+              LT -> Color.Red+              EQ -> Color.White+              GT -> Color.Green+        in map (Color.attrChar2ToW32 cbonus) tbonus+  let kitAssOnlyWeapons =+        filter (IA.checkFlag Ability.Meleeable+                . aspectRecordFull . fst . snd) kitAssRaw+  discoBenefit <- getsClient sdiscoBenefit+  strongest <-+    map (\(_, hasEffect, timeout, ncha, _, itemFullKit) ->+          (hasEffect, timeout, ncha, itemFullKit))+    <$> pickWeaponM True (Just discoBenefit) kitAssOnlyWeapons+                    actorCurAndMaxSk leader+  let possiblyHasTimeout (_, timeout, _, (itemFull, _)) =+        timeout > 0 || itemSuspect itemFull+      (lT, lTrest) = span possiblyHasTimeout strongest+      strongestToDisplay = lT ++ case lTrest of+        [] -> []+        noTimeout : lTrest2 -> noTimeout : filter possiblyHasTimeout lTrest2+          -- the second portion of timeout weapons won't ever be used+          -- but often it's the player's mistake, so show them anyway+      showStrongest showInBrief l =+        let lToDisplay = concatMap (ppDice showInBrief) l+            (ldischarged, lrest) = break fst lToDisplay+            lWithBonus = case map snd lrest of+              [] -> []  -- no timeout-free organ, e.g., rattlesnake or hornet+              (ldmg, lextra) : rest -> (ldmg ++ lbonus, lextra) : rest+            displayDmgAndExtra (ldmg, lextra) =+              if attrStringToString ldmg == "0"+              then case lextra of+                [] -> ldmg+                _plus : lextraRest -> lextraRest+              else ldmg ++ lextra+        in intercalate [Color.spaceAttrW32]+           $ map displayDmgAndExtra $ map snd ldischarged ++ lWithBonus+      lFull = showStrongest False strongestToDisplay+      lBrief = showStrongest True strongestToDisplay+      lFits | length lFull <= width = lFull+                -- the prevailing case, so optimized for this case only+            | length lBrief <= width = lBrief+            | otherwise = take (width - 3) lBrief ++ stringToAS "..."+  return $! lFits++drawSelected :: MonadClientUI m+             => LevelId -> Int -> ES.EnumSet ActorId -> m (Int, AttrString)+drawSelected drawnLevelId width selected = do+  mleader <- getsClient sleader+  side <- getsClient sside+  sactorUI <- getsSession sactorUI+  ours <- getsState $ filter (not . bproj . snd)+                      . inline actorAssocs (== side) drawnLevelId+  let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours+      viewOurs (aid, Actor{bhp, bwatch}, ActorUI{bsymbol, bcolor}) =+        -- Sleep considered before being selected, because sleeping+        -- actors can't move, so selection is mostly irrelevant.+        -- Domination not considered at all, because map already shows it+        -- and so here is the only place where selection is conveyed.+        let bg = if | mleader == Just aid -> Color.HighlightYellow+                    | bwatch == WSleep -> Color.HighlightBlue+                    | ES.member aid selected -> Color.HighlightGreen+                    | otherwise -> Color.HighlightNone+            sattr = Color.Attr {Color.fg = bcolor, bg}+        in Color.attrCharToW32 $ Color.AttrChar sattr+           $ if bhp > 0 then bsymbol else '%'+      maxViewed = width - 2+      len = length oursUI+      star = let fg = case ES.size selected of+                   0 -> Color.BrBlack+                   n | n == len -> Color.BrWhite+                   _ -> Color.defFG+                 char = if len > maxViewed then '$' else '*'+             in Color.attrChar2ToW32 fg char+      viewed = map viewOurs $ take maxViewed+               $ sortOn keySelected oursUI+  return (min width (len + 2), [star] ++ viewed ++ [Color.spaceAttrW32])++checkWarningHP :: UIOptions -> ActorId -> Int64 -> State -> Bool+checkWarningHP UIOptions{uhpWarningPercent} leader hp s =+  let actorCurAndMaxSk = getActorMaxSkills leader s+      maxHp = Ability.getSk Ability.SkMaxHP actorCurAndMaxSk+  in hp <= xM (uhpWarningPercent * maxHp `div` 100)++checkWarningCalm :: UIOptions -> ActorId -> Int64 -> State -> Bool+checkWarningCalm UIOptions{uhpWarningPercent} leader calm s =+  let b = getActorBody leader s+      actorCurAndMaxSk = getActorMaxSkills leader s+      isImpression iid =+        maybe False (> 0) $ lookup IK.S_IMPRESSED $ IK.ifreq $ getIidKind iid s+      isImpressed = any isImpression $ EM.keys $ borgan b+      maxCalm = Ability.getSk Ability.SkMaxCalm actorCurAndMaxSk+  in calm <= xM (uhpWarningPercent * maxCalm `div` 100)+     && isImpressed++checkWarnings :: UIOptions -> ActorId -> State -> (Bool, Bool)+checkWarnings uiOptions leader s =+  let b = getActorBody leader s+  in ( checkWarningHP uiOptions leader (bhp b) s+     , checkWarningCalm uiOptions leader (bcalm b) s )
+ engine-src/Game/LambdaHack/Client/UI/EffectDescription.hs view
@@ -0,0 +1,554 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Description of effects.+module Game.LambdaHack.Client.UI.EffectDescription+  ( DetailLevel(..), defaultDetailLevel+  , effectToSuffix, detectToObject, detectToVerb+  , skillName, skillDesc, skillToDecorator, skillsInDisplayOrder+  , kindAspectToSuffix, aspectToSentence, affixDice+  , describeToolsAlternative, describeCrafting, wrapInParens+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , conditionToObject, activationFlagToObject, slotToSentence, tmodToSuff+  , affixBonus, wrapInChevrons+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.Text as T+import           GHC.Generics (Generic)+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Definition.Ability+import           Game.LambdaHack.Definition.Defs++data DetailLevel = DetailLow | DetailMedium | DetailHigh | DetailAll+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary DetailLevel++defaultDetailLevel :: DetailLevel+defaultDetailLevel = DetailAll  -- TODO: take from config file, #217++-- | Suffix to append to a basic content name if the content causes the effect.+--+-- We show absolute time in seconds, not @moves@, because actors can have+-- different speeds (and actions can potentially take different time intervals).+-- We call the time taken by one player move, when walking, a @move@.+-- @Turn@ and @clip@ are used mostly internally, the former as an absolute+-- time unit.+-- We show distances in @steps@, because one step, from a tile to another+-- tile, is always 1 meter. We don't call steps @tiles@, reserving+-- that term for the context of terrain kinds or units of area.+effectToSuffix :: DetailLevel -> Effect -> Text+effectToSuffix detailLevel effect =+  case effect of+    Burn d -> wrapInParens (tshow d+                            <+> if Dice.supDice d > 1 then "burns" else "burn")+    Explode t -> "of" <+> displayGroupName t <+> "explosion"+    RefillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)+    RefillHP 0 -> error $ "" `showFailure` effect+    RefillHP p -> "of wounding" <+> wrapInParens (tshow $ abs p)+    RefillCalm p | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p)+    RefillCalm 0 -> error $ "" `showFailure` effect+    RefillCalm p -> "of dismaying" <+> wrapInParens (tshow $ abs p)+    Dominate -> "of domination"+    Impress -> "of impression"+    PutToSleep -> "of sleep"+    Yell -> "of alarm"  -- minor, but if under timeout, differentiates items+    Summon grp d -> makePhrase+      [ "of summoning"+      , if Dice.supDice d <= 1 then "" else MU.Text $ tshow d+      , MU.Ws $ MU.Text $ displayGroupName grp ]+    ApplyPerfume -> "of smell removal"+    Ascend True -> "of ascending"+    Ascend False -> "of descending"+    Escape{} -> "of escaping"+    Paralyze dice ->+      let time = case Dice.reduceDice dice of+            Nothing -> tshow dice <+> "* 0.05s"+            Just p ->+              let dt = timeDeltaScale (Delta timeClip) p+              in timeDeltaInSecondsText dt+      in "of paralysis for" <+> time+    ParalyzeInWater dice ->+      let time = case Dice.reduceDice dice of+            Nothing -> tshow dice <+> "* 0.05s"+            Just p ->+              let dt = timeDeltaScale (Delta timeClip) p+              in timeDeltaInSecondsText dt+      in "of retardation for" <+> time+    InsertMove dice ->+      let moves = case Dice.reduceDice dice of+            Nothing -> tshow dice <+> "tenths of a move"+            Just p ->+              let (d, m) = p `divMod` 10+              in if m == 0+                 then makePhrase [MU.CarWs d "move"]+                 else makePhrase [MU.Car1Ws p "tenth", "of a move"]+      in "of speed surge for" <+> moves+    Teleport dice | Dice.supDice dice <= 9 ->+      "of blinking" <+> wrapInParens (tshow dice)+    Teleport dice -> "of teleport" <+> wrapInParens (tshow dice)+    CreateItem _ COrgan grp tim ->+      let stime = if isTimerNone tim then "" else "for" <+> tshow tim <> ":"+      in "(keep" <+> stime <+> displayGroupName grp <> ")"+    CreateItem _ _ grp _ ->+      makePhrase ["of gain", MU.AW $ MU.Text $ displayGroupName grp]+    DestroyItem{} -> "of loss"+    ConsumeItems{} -> "of consumption from the ground"+      -- too much noise from crafting+    DropItem n k store grp ->+      let (preT, postT) =+            if | n == 1 && k == maxBound -> ("one", "kind")+               | n == maxBound && k == maxBound -> ("all", "kinds")+               | k == 1 || store /= COrgan -> ("", "")+               | k == maxBound -> ("", "condition fully")+               | otherwise -> ("", "condition" <+> tshow k <> "-fold")+          (verb, fromStore) =+            if store == COrgan+            then ("nullify", "")+            else ("drop", "from" <+> snd (ppCStore store))+      in "of" <+> verb <+> preT <+> displayGroupName grp <+> postT <+> fromStore+    Recharge n dice ->+      let times = if n == 1 then "" else tshow n <+> "times"+      in case Dice.reduceDice dice of+        Nothing -> "of recharge" <+> times+                   <+> "by" <+> tshow dice <+> "* 0.05s"+        Just p -> let dt = timeDeltaScale (Delta timeClip) p+                  in "of recharge" <+> times+                     <+> "by" <+> timeDeltaInSecondsText dt+    Discharge n dice ->+      let times = if n == 1 then "" else tshow n <+> "times"+      in case Dice.reduceDice dice of+        Nothing -> "of discharge" <+> times+                   <+> "by" <+> tshow dice <+> "* 0.05s"+        Just p -> let dt = timeDeltaScale (Delta timeClip) p+                  in "of discharge" <+> times+                     <+> "by" <+> timeDeltaInSecondsText dt+    PolyItem -> "of repurpose on the ground"+    RerollItem -> "of deeply reshape on the ground"+    DupItem -> "of multiplication on the ground"+    Identify -> "of identify"+    Detect d radius ->+      "of" <+> detectToObject d <+> "location" <+> wrapInParens (tshow radius)+    SendFlying tmod -> "of impact" <+> tmodToSuff "" tmod+    PushActor tmod -> "of pushing" <+> tmodToSuff "" tmod+    PullActor tmod -> "of pulling" <+> tmodToSuff "" tmod+    AtMostOneOf effs ->+      let ts = filter (/= "") $ map (effectToSuffix detailLevel) effs+          subject = "marvel"+          header = makePhrase ["of", MU.CardinalWs (length ts) subject]+          sometimes = if length effs > length ts then "(sometimes)" else ""+      in case ts of+        [] -> ""+        [wonder] -> wonder <+> sometimes+        _ | detailLevel < DetailHigh -> header+        _ -> header <+> "[" <> T.intercalate ", " ts <> "]" <+> sometimes+    OneOf effs ->+      let ts = filter (/= "") $ map (effectToSuffix detailLevel) effs+          subject = "wonder"+          header = makePhrase ["of", MU.CardinalWs (length ts) subject]+          sometimes = if length effs > length ts then "(sometimes)" else ""+      in case ts of+        [] -> ""+        [wonder] -> wonder <+> sometimes+        _ | detailLevel < DetailHigh -> header+        _ -> header <+> "[" <> T.intercalate ", " ts <> "]" <+> sometimes+    OnSmash _ -> ""  -- printed inside a separate section+    OnCombine _ -> ""  -- printed inside a separate section+    OnUser eff -> let t = effectToSuffix detailLevel eff+                  in if T.null t then "" else "(on user:" <+> t <> ")"+    NopEffect -> ""  -- never printed+    AndEffect (ConsumeItems tools raw) eff -> case detailLevel of+     DetailLow -> "of crafting"+     DetailMedium -> "of crafting (recipes in lore menu)"+     _ ->+       let (tcraft, traw, ttools) = describeCrafting tools raw eff+       in tcraft <+> traw <+> ttools+    AndEffect eff1 eff2 ->+      let t = T.intercalate " and then "+              $ nub $ filter (not . T.null)+              $ map (effectToSuffix detailLevel) [eff1, eff2]+      in if T.null t then "of conjunctive processing" else t+    OrEffect eff1 eff2 ->+      let t = T.intercalate " or else "+              $ nub $ filter (not . T.null)+              $ map (effectToSuffix detailLevel) [eff1, eff2]+      in if T.null t then "of alternative processing" else t+    SeqEffect effs ->+      let t = T.intercalate " then "+              $ nub $ filter (not . T.null)+              $ map (effectToSuffix detailLevel) effs+      in if T.null t then "of sequential processing" else t+    When cond eff ->+      let object = conditionToObject cond+          object2 = effectToSuffix detailLevel eff+      in if T.null object2+         then ""  -- no 'conditional processing' --- probably a hack+         else "(when" <+> object <+> "then" <+> object2 <> ")"+    Unless cond eff ->+      let object = conditionToObject cond+          object2 = effectToSuffix detailLevel eff+      in if T.null object2+         then ""+         else "(unless" <+> object <+> "then" <+> object2 <> ")"+    IfThenElse cond eff1 eff2 ->+      let object = conditionToObject cond+          object1 = effectToSuffix detailLevel eff1+          object2 = effectToSuffix detailLevel eff2+      in if T.null object1 && T.null object2+         then ""+         else "(if" <+> object <+> "then" <+> object1+                               <+> "else" <+> object2 <> ")"+    VerbNoLonger{} -> ""  -- no description for a flavour effect+    VerbMsg{} -> ""  -- no description for an effect that prints a description+    VerbMsgFail{} -> ""++conditionToObject :: Condition -> Text+conditionToObject = \case+  HpLeq n -> "HP <=" <+> tshow n+  HpGeq n -> "HP >=" <+> tshow n+  CalmLeq n -> "Calm <=" <+> tshow n+  CalmGeq n -> "Calm >=" <+> tshow n+  TriggeredBy activationFlag ->+    "activated" <+> activationFlagToObject activationFlag++activationFlagToObject :: ActivationFlag -> Text+activationFlagToObject = \case+  ActivationMeleeable -> "by meleeing"+  ActivationPeriodic -> "periodically"+  ActivationUnderRanged -> "under ranged attack"+  ActivationUnderMelee -> "under melee attack"+  ActivationProjectile -> "when flung"+  ActivationTrigger -> "by triggering"+  ActivationOnSmash -> "on smash"+  ActivationOnCombine -> "when combined"+  ActivationEmbed -> "embedded in terrain"+  ActivationConsume -> "when consumed"++detectToObject :: DetectKind -> Text+detectToObject d = case d of+  DetectAll -> "detail"+  DetectActor -> "intruder"+  DetectLoot -> "merchandise"+  DetectExit -> "exit"+  DetectHidden -> "secret"+  DetectEmbed -> "feature"+  DetectStash -> "stash"++detectToVerb :: DetectKind -> Text+detectToVerb d = case d of+  DetectAll -> "map all"+  DetectActor -> "spot nearby"+  DetectLoot -> "locate nearby"+  DetectExit -> "learn nearby"+  DetectHidden -> "uncover nearby"+  DetectEmbed -> "notice nearby"+  DetectStash -> "locate"++slotToSentence :: EqpSlot -> Text+slotToSentence es = case es of+  EqpSlotMove -> "Those unskilled in locomotion equip it."+  EqpSlotMelee -> "Those unskilled in close combat equip it."+  EqpSlotDisplace -> "Those unskilled in moving in crowds equip it."+  EqpSlotAlter -> "Those unskilled in terrain modification equip it."+  EqpSlotWait -> "Those unskilled in watchfulness equip it."+  EqpSlotMoveItem -> "Those unskilled in inventory management equip it."+  EqpSlotProject -> "Those unskilled in item flinging equip it."+  EqpSlotApply -> "Those unskilled in applying items equip it."+  EqpSlotSwimming -> "Useful to any that wade or swim in water."+  EqpSlotFlying -> "Those not afraid to fly, put it on."+  EqpSlotHurtMelee -> "Veteran melee fighters are known to devote equipment slot to it."+  EqpSlotArmorMelee -> "Worn by people in risk of melee wounds."+  EqpSlotArmorRanged -> "People scared of shots in the dark wear it."+  EqpSlotMaxHP -> "The frail wear it to increase their Hit Point capacity."+  EqpSlotSpeed -> "The sluggish equip it to speed up their whole life."+  EqpSlotSight -> "The short-sighted wear it to notice their demise sooner."+  EqpSlotShine -> "Explorers brave enough to highlight themselves put it in their equipment."+  EqpSlotMiscBonus -> "Those that don't scorn minor bonuses may equip it."+  EqpSlotWeaponFast -> "Close range fighters pick it as their mainstay weapon."+  EqpSlotWeaponBig -> "Close range fighters pick it as their opening weapon."++skillName :: Skill -> Text+skillName SkMove = "move stat"+skillName SkMelee = "melee stat"+skillName SkDisplace = "displace stat"+skillName SkAlter = "modify terrain stat"+skillName SkWait = "wait stat"+skillName SkMoveItem = "manage items stat"+skillName SkProject = "fling stat"+skillName SkApply = "trigger stat"+skillName SkSwimming = "swimming"+skillName SkFlying = "flying"+skillName SkHurtMelee = "to melee damage"+skillName SkArmorMelee = "melee armor"+skillName SkArmorRanged = "ranged armor"+skillName SkMaxHP = "max HP"+skillName SkMaxCalm = "max Calm"+skillName SkSpeed = "speed"+skillName SkSight = "sight radius"+skillName SkSmell = "smell radius"+skillName SkShine = "shine radius"+skillName SkNocto = "noctovision radius"+skillName SkHearing = "hearing radius"+skillName SkAggression = "aggression level"+skillName SkOdor = "odor level"+skillName SkDeflectRanged = "ranged deflection"+skillName SkDeflectMelee = "melee deflection"++skillDesc :: Skill -> Text+skillDesc skill =+  let skName = skillName skill+      capSkillName = "The '" <> skName <> "' skill"+      capStatName = "The '" <> T.unwords (init $ T.words skName) <> "' stat"+  in case skill of+    SkMove -> capStatName <+>+      "determines whether the character can move. Actors not capable of movement can't be dominated."+    SkMelee -> capStatName <+>+      "determines whether the character can melee. Actors that can't melee can still cause damage by flinging missiles or by ramming (being pushed) at opponents."+    SkDisplace -> capStatName <+>+      "determines whether the character can displace adjacent actors. In some cases displacing is not possible regardless of skill: when the target is braced, dying, has no move skill or when both actors are supported by adjacent friendly units. Missiles can be displaced always, unless more than one occupies the map location."+    SkAlter -> capStatName <+>+      "determines which kinds of terrain can be activated and modified by the character. Opening doors and searching suspect tiles require skill 2, some stairs require 3, closing doors requires 4, others require 4 or 5. Actors not smart enough to be capable of using stairs can't be dominated."+    SkWait -> capStatName <+>+      "determines whether the character can wait, brace for combat (potentially blocking the effects of some attacks), sleep and lurk."+    SkMoveItem -> capStatName <+>+      "determines whether the character can pick up items and manage inventory."+    SkProject -> capStatName <+>+      "determines which kinds of items the character can propel. Items that can be lobbed to explode at a precise location, such as flasks, require skill 3. Other items travel until they meet an obstacle and skill 1 is enough to fling them. In some cases, e.g., of too intricate or two awkward items at low Calm, throwing is not possible regardless of the skill value."+    SkApply -> capStatName <+>+      "determines which kinds of items the character can use. Items that assume literacy require skill 2, others can be used already at skill 1. In some cases, e.g., when the item needs recharging, has no possible effects or is too intricate for distracted use, triggering may not be possible."+    SkSwimming -> capSkillName <+>+      "is the degree of avoidance of bad effects of terrain containing water, whether shallow or deep."+    SkFlying -> capSkillName <+>+      "is the degree of avoidance of bad effects of any hazards spread on the ground."+    SkHurtMelee -> capSkillName <+>+      "is a percentage of additional damage dealt by the actor (either a character or a missile) with any weapon. The value is capped at 200% and then the armor percentage of the defender is subtracted from it."+    SkArmorMelee -> capSkillName <+>+      "is a percentage of melee damage avoided by the actor. The value is capped at 200%, then the extra melee damage percentage of the attacker is subtracted from it and the resulting total is capped at 95% (always at least 5% of damage gets through). It includes 50% bonus from being braced for combat, if applicable."+    SkArmorRanged -> capSkillName <+>+      "is a percentage of ranged damage avoided by the actor. The value is capped at 200%, then the extra melee damage percentage of the attacker is subtracted from it and the resulting total is capped at 95% (always at least 5% of damage gets through). It includes 25% bonus from being braced for combat, if applicable."+    SkMaxHP -> capSkillName <+>+      "is a cap on HP of the actor, except for some rare effects able to overfill HP. At any direct enemy damage (but not, e.g., incremental poisoning damage or wounds inflicted by mishandling a device) HP is cut back to the cap."+    SkMaxCalm -> capSkillName <+>+      "is a cap on Calm of the actor, except for some rare effects able to overfill Calm. At any direct enemy damage (but not, e.g., incremental poisoning damage or wounds inflicted by mishandling a device) Calm is lowered, sometimes very significantly and always at least back down to the cap."+    SkSpeed -> capSkillName <+>+      "is expressed in meters per second, which corresponds to map location (1m by 1m) per two standard turns (0.5s each). Thus actor at standard speed of 2m/s moves one location per standard turn."+    SkSight -> capSkillName <+>+      "is the limit of visibility in light. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    SkSmell -> capSkillName <+>+      "determines the maximal area smelled by the actor. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    SkShine -> capSkillName <+>+      "determines the maximal area lit by the actor. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    SkNocto -> capSkillName <+>+      "is the limit of visibility in dark. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    SkHearing -> capSkillName <+>+      "is the limit of hearing. The radius is measured from the middle of the map location occupied by the character to the edge of the furthest covered location."+    SkAggression -> "The '" <> skName <> "' property" <+>+      "represents the willingness of the actor to engage in combat, especially close quarters, and conversely, to break engagement when overpowered."+    SkOdor -> "The '" <> skName <> "' property" <+>+      "represents the ability to communicate (more specifically, communicate one's presence) through personal odor. Zero or less means the odor is not trackable."+    SkDeflectRanged -> "The '" <> skName <> "' property" <+>+      "tells whether complete invulnerability to ranged attacks, piercing and of every other kind, is effective, and from how many sources."+    SkDeflectMelee -> "The '" <> skName <> "' property" <+>+      "tells whether complete invulnerability to melee attacks, piercing and of every other kind, is effective, and from how many sources."++skillToDecorator :: Skill -> Actor -> Int -> Text+skillToDecorator skill b t =+  let tshow200 n = let n200 = min 200 $ max (-200) n+                   in tshow n200 <> if n200 /= n then "$" else ""+      -- Some values can be negative, for others 0 is equivalent but shorter.+      tshowRadius r = case compare r 0 of+                        GT -> tshow (r - 1) <> ".5m"+                        EQ -> "0m"+                        LT -> tshow (r + 1) <> ".5m"+  in case skill of+    SkMove -> tshow t+    SkMelee -> tshow t+    SkDisplace -> tshow t+    SkAlter -> tshow t+    SkWait -> tshow t+    SkMoveItem -> tshow t+    SkProject -> tshow t+    SkApply -> tshow t+    SkSwimming -> tshow t+    SkFlying -> tshow t+    SkHurtMelee -> tshow200 t <> "%"+    SkArmorMelee -> "[" <> tshow200 t <> "%]"+    SkArmorRanged -> "{" <> tshow200 t <> "%}"+    SkMaxHP -> tshow $ max 0 t+    SkMaxCalm -> tshow $ max 0 t+    SkSpeed -> T.pack $ displaySpeed t+    SkSight ->+      let tcapped = min (fromEnum $ bcalm b `div` xM 5) t+      in tshowRadius tcapped+         <+> if tcapped == t+             then ""+             else "(max" <+> tshowRadius t <> ")"+    SkSmell -> tshowRadius t+    SkShine -> tshowRadius t+    SkNocto -> tshowRadius t+    SkHearing -> tshowRadius t+    SkAggression -> tshow t+    SkOdor -> tshow t+    SkDeflectRanged -> tshow t+    SkDeflectMelee -> tshow t++skillsInDisplayOrder :: [Skill]+skillsInDisplayOrder = [minBound .. maxBound]++tmodToSuff :: Text -> ThrowMod -> Text+tmodToSuff verb ThrowMod{..} =+  let vSuff | throwVelocity == 100 = ""+            | otherwise = "v=" <> tshow throwVelocity <> "%"+      tSuff | throwLinger == 100 = ""+            | otherwise = "t=" <> tshow throwLinger <> "%"+      hSuff | throwHP == 1 = ""+            | otherwise = "pierce=" <> tshow throwHP+  in if vSuff == "" && tSuff == "" && hSuff == "" then ""+     else verb <+> "with" <+> vSuff <+> tSuff <+> hSuff++kindAspectToSuffix :: Aspect -> Text+kindAspectToSuffix aspect =+  case aspect of+    Timeout{} -> ""  -- printed specially+    AddSkill SkMove t -> wrapInParens $ affixDice t <+> "move"+    AddSkill SkMelee t -> wrapInParens $ affixDice t <+> "melee"+    AddSkill SkDisplace t -> wrapInParens $ affixDice t <+> "displace"+    AddSkill SkAlter t -> wrapInParens $ affixDice t <+> "modify"+    AddSkill SkWait t -> wrapInParens $ affixDice t <+> "wait"+    AddSkill SkMoveItem t -> wrapInParens $ affixDice t <+> "manage items"+    AddSkill SkProject t -> wrapInParens $ affixDice t <+> "fling"+    AddSkill SkApply t -> wrapInParens $ affixDice t <+> "trigger"+    AddSkill SkSwimming t -> wrapInParens $ affixDice t <+> "swimming"+    AddSkill SkFlying t -> wrapInParens $ affixDice t <+> "flying"+    AddSkill SkHurtMelee _ ->+      ""  -- printed together with dice, even if dice is zero+    AddSkill SkArmorMelee t -> "[" <> affixDice t <> "%]"+    AddSkill SkArmorRanged t -> "{" <> affixDice t <> "%}"+    AddSkill SkMaxHP t -> wrapInParens $ affixDice t <+> "HP"+    AddSkill SkMaxCalm t -> wrapInParens $ affixDice t <+> "Calm"+    AddSkill SkSpeed t -> wrapInParens $ affixDice t <+> "speed"+    AddSkill SkSight t -> wrapInParens $ affixDice t <+> "sight"+    AddSkill SkSmell t -> wrapInParens $ affixDice t <+> "smell"+    AddSkill SkShine t -> wrapInParens $ affixDice t <+> "shine"+    AddSkill SkNocto t -> wrapInParens $ affixDice t <+> "night vision"+    AddSkill SkHearing t -> wrapInParens $ affixDice t <+> "hearing"+    AddSkill SkAggression t -> wrapInParens $ affixDice t <+> "aggression"+    AddSkill SkOdor t -> wrapInParens $ affixDice t <+> "odor"+    AddSkill SkDeflectRanged d ->+      if | Dice.infDice d >= 1 -> wrapInChevrons "deflecting ranged attacks"+         | Dice.supDice d <= -1 -> wrapInChevrons "vulnerable to ranged attacks"+         | otherwise -> ""  -- bad content?+    AddSkill SkDeflectMelee d ->+      if | Dice.infDice d >= 1 -> wrapInChevrons "deflecting melee attacks"+         | Dice.supDice d <= -1 -> wrapInChevrons "vulnerable to melee attacks"+         | otherwise -> ""  -- bad content?+    SetFlag Fragile -> wrapInChevrons "fragile"+    SetFlag Lobable -> wrapInChevrons "can be lobbed"+    SetFlag Durable -> wrapInChevrons "durable"+    SetFlag Equipable -> ""+    SetFlag Benign -> ""+    SetFlag Precious -> ""+    SetFlag Blast -> ""+    SetFlag Condition -> ""+    SetFlag Unique -> ""  -- named specially by the content writer+    SetFlag MetaGame -> ""+    SetFlag MinorEffects -> ""  -- cryptic override+    SetFlag MinorAspects -> ""  -- cryptic override+    SetFlag Meleeable -> ""+    SetFlag Periodic -> ""  -- printed specially+    SetFlag UnderRanged -> wrapInChevrons "applied under ranged attack"+    SetFlag UnderMelee -> wrapInChevrons "applied under melee attack"+    ELabel{} -> ""  -- too late+    ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod+    PresentAs{} -> ""+    EqpSlot{} -> ""  -- used in @slotToSentence@ instead+    Odds{} -> ""++aspectToSentence :: Aspect -> Maybe Text+aspectToSentence feat =+  case feat of+    Timeout{} -> Nothing+    AddSkill{} -> Nothing+    SetFlag Fragile -> Nothing+    SetFlag Lobable -> Nothing+    SetFlag Durable -> Nothing+    SetFlag Equipable -> Nothing+    SetFlag Benign -> Just "It affects the opponent in a benign way."+    SetFlag Precious -> Just "It seems precious."+    SetFlag Blast -> Nothing+    SetFlag Condition -> Nothing+    SetFlag Unique -> Just "It is one of a kind."+    SetFlag MetaGame -> Just "It's so characteristic that it's recognizable every time after being identified once, even under very different circumstances."+    SetFlag MinorEffects -> Nothing+    SetFlag MinorAspects -> Nothing+    SetFlag Meleeable -> Just "It is considered for melee strikes."+    SetFlag Periodic -> Nothing+    SetFlag UnderRanged -> Nothing+    SetFlag UnderMelee -> Nothing+    ELabel{} -> Nothing+    ToThrow{} -> Nothing+    PresentAs{} -> Nothing+    EqpSlot es -> Just $ slotToSentence es+    Odds{} -> Just "Individual specimens sometimes have yet other properties."++affixBonus :: Int -> Text+affixBonus p = case compare p 0 of+  EQ -> "0"+  LT -> tshow p+  GT -> "+" <> tshow p++wrapInParens :: Text -> Text+wrapInParens "" = ""+wrapInParens t = "(" <> t <> ")"++wrapInChevrons :: Text -> Text+wrapInChevrons "" = ""+wrapInChevrons t = "<" <> t <> ">"++affixDice :: Dice.Dice -> Text+affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d++describeTools :: [(Int, GroupName ItemKind)] -> MU.Part+describeTools =+  let carAWs (k, grp) = MU.CarAWs k (MU.Text $ displayGroupName grp)+  in MU.WWandW . map carAWs++describeToolsAlternative :: [[(Int, GroupName ItemKind)]] -> Text+describeToolsAlternative grps =+  T.intercalate " or " $ map (\grp -> makePhrase [describeTools grp])+                       $ filter (not . null) grps++describeCrafting :: [(Int, GroupName ItemKind)]+                 -> [(Int, GroupName ItemKind)]+                 -> Effect+                 -> (Text, Text, Text)+describeCrafting tools raw eff =+  let unCreate (CreateItem (Just k) _ grp _) = [(k, grp)]+      unCreate (SeqEffect effs) = concatMap unCreate effs+      unCreate _ = []+      grpsCreate = unCreate eff+      tcraft = makePhrase $+        "of crafting"+        : (if null grpsCreate+           then ["nothing"]+           else [describeTools grpsCreate])+      traw = makePhrase $+        if null raw+        then []+        else ["from", describeTools raw]+      ttools = makePhrase $+        if null tools+        then []+        else ["using", describeTools tools]+  in (tcraft, traw, ttools)
+ engine-src/Game/LambdaHack/Client/UI/Frame.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE RankNTypes #-}+-- | Screen frames.+--+-- Note that @PointArray.Array@ here represents a screen frame and so+-- screen positions are denoted by @Point@, contrary to the convention+-- that @Point@ refers to game map coordinates, as outlined+-- in description of 'PointSquare' that should normally be used in that role.+module Game.LambdaHack.Client.UI.Frame+  ( ColorMode(..)+  , FrameST, FrameForall(..), FrameBase(..), Frame+  , PreFrame3, PreFrames3, PreFrame, PreFrames+  , SingleFrame(..), OverlaySpace+  , blankSingleFrame, truncateOverlay, overlayFrame+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , truncateAttrLine+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Monad.ST.Strict+import           Data.Function+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import           Data.Word++import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import qualified Game.LambdaHack.Common.PointArray as PointArray+import qualified Game.LambdaHack.Definition.Color as Color++-- | Color mode for the display.+data ColorMode =+    ColorFull  -- ^ normal, with full colours+  | ColorBW    -- ^ black and white only+  deriving Eq++type FrameST s = G.Mutable U.Vector s Word32 -> ST s ()++-- | Efficiently composable representation of an operation+-- on a frame, that is, on a mutable vector. When the composite operation+-- is eventually performed, the vector is frozen to become a 'SingleFrame'.+newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s}++-- | Action that results in a base frame, to be modified further.+newtype FrameBase = FrameBase+  {unFrameBase :: forall s. ST s (G.Mutable U.Vector s Word32)}++-- | A frame, that is, a base frame and all its modifications.+type Frame = ( (FrameBase, FrameForall)+             , (OverlaySpace, OverlaySpace, OverlaySpace) )++-- | Components of a frame, before it's decided if the first can be overwritten+-- in-place or needs to be copied.+type PreFrame3 = (PreFrame, (OverlaySpace, OverlaySpace, OverlaySpace))++-- | Sequence of screen frames, including delays. Potentially based on a single+-- base frame.+type PreFrames3 = [Maybe PreFrame3]++-- | A simpler variant of @PreFrame3@.+type PreFrame = (U.Vector Word32, FrameForall)++-- | A simpler variant of @PreFrames3@.+type PreFrames = [Maybe PreFrame]++-- | Representation of an operation of overwriting a frame with a single line+-- at the given row.+writeLine :: Int -> AttrString -> FrameForall+{-# INLINE writeLine #-}+writeLine offset al = FrameForall $ \v -> do+  let writeAt _ [] = return ()+      writeAt off (ac32 : rest) = do+        VM.write v off (Color.attrCharW32 ac32)+        writeAt (off + 1) rest+  writeAt offset al++-- | A frame that is padded to fill the whole screen with optional+-- overlays to display in proportional, square and monospace fonts.+--+-- Note that we don't provide a list of color-highlighed box positions+-- to be drawn separately, because overlays need to obscure not only map,+-- but the highlights as well, so highlights need to be included earlier.+--+-- See the description of 'PointSquare' for explanation of why screen+-- coordinates in @singleArray@ are @Point@ even though they should be+-- 'PointSquare'.+data SingleFrame = SingleFrame+  { singleArray         :: PointArray.Array Color.AttrCharW32+  , singlePropOverlay   :: OverlaySpace+  , singleSquareOverlay :: OverlaySpace+  , singleMonoOverlay   :: OverlaySpace }+  deriving (Show, Eq)++type OverlaySpace = [(PointUI, AttrString)]++blankSingleFrame :: ScreenContent -> SingleFrame+blankSingleFrame ScreenContent{rwidth, rheight} =+  SingleFrame (PointArray.replicateA rwidth rheight Color.spaceAttrW32)+              []+              []+              []++-- | Truncate the overlay: for each line, if it's too long, it's truncated+-- and if there are too many lines, excess is dropped and warning is appended.+-- The width, in the second argument, is calculated in characters,+-- not in UI (mono font) coordinates, so that taking and dropping characters+-- is performed correctly.+truncateOverlay :: Bool -> Int -> Int -> Bool -> Int -> Bool -> Overlay+                -> OverlaySpace+truncateOverlay halveXstart width rheight wipeAdjacentRaw fillLen onBlank ov =+  let wipeAdjacent = wipeAdjacentRaw && not onBlank+      canvasLength = if onBlank then rheight else rheight - 2+      supHeight = maxYofOverlay ov+      trimmedY = canvasLength - 1+      -- Sadly, this does not trim the other, concurrent, overlays that may+      -- obscure the last line and so contend with the "trimmed" message.+      -- Tough luck; just avoid overrunning overlays in higher level code.+      ovTopFiltered = filter (\(PointUI _ y, _) -> y < trimmedY) ov+      trimmedAlert = ( PointUI 0 trimmedY+                     , stringToAL "--a portion of the text trimmed--" )+      extraLine | supHeight < 3+                  || supHeight >= trimmedY+                  || not wipeAdjacent = []+                | otherwise =+        let supHs = filter (\(PointUI _ y, _) -> y == supHeight) ov+        in if null supHs+           then []+           else let (PointUI xLast yLast, _) =+                      minimumBy (comparing $ \(PointUI x _, _) -> x) supHs+                in [(PointUI xLast (yLast + 1), emptyAttrLine)]+      -- This is crude, because an al at lower x may be longer, but KISS.+      -- This also gives a solid rule which al overwrite others+      -- when merging overlays, independent of the order of merging+      -- (except for duplicate x, for which initial order is retained).+      -- The order functions is cheap, we use @sortBy@, not @sortOn@.+      ovTop = groupBy ((==) `on` \(PointUI _ y, _) -> y)+              $ sortBy (comparing $ \(PointUI x y, _) -> (y, x))+              $ if supHeight >= canvasLength+                then ovTopFiltered ++ [trimmedAlert]+                else ov ++ extraLine+      -- Unlike the trimming above, adding spaces around overlay depends+      -- on there being no gaps and a natural order.+      -- Probably also gives messy results when X offsets are not all the same.+      -- Below we at least mitigate the case of multiple lines per row.+      f _ _ [] = error "empty list of overlay lines at the given row"+      f (yPrev, lenPrev) (yNext, lenNext) (minAl@(PointUI _ yCur, _) : rest) =+        g (if yPrev == yCur - 1 then lenPrev else 0)+          (if yNext == yCur + 1 then lenNext else 0)+          fillLen+          minAl+        : map (g 0 0 0) rest+      g lenPrev lenNext fillL (p@(PointUI xstartRaw _), layerLine) =+        let xstart = if halveXstart then xstartRaw `div` 2 else xstartRaw+            -- TODO: lenPrev and lenNext is from the same kind of font;+            -- if fonts are mixed, too few spaces are added.+            -- We'd need to keep a global store of line lengths+            -- for every position on the screen, filled first going+            -- over all texts and only afterwards texts rendered.+            -- And prop font measure would still make this imprecise.+            -- TODO: rewrite ovBackdrop according to this idea,+            -- but then process square font only mode with the same mechanism.+            maxLen = if wipeAdjacent then max lenPrev lenNext else 0+            fillFromStart = max fillL (1 + maxLen) - xstart+            available = width - xstart+        in (p, truncateAttrLine wipeAdjacent available fillFromStart layerLine)+      rightExtentOfLine (PointUI xstartRaw _, al) =+        let xstart = if halveXstart then xstartRaw `div` 2 else xstartRaw+        in min (width - 1) (xstart + length (attrLine al))+      yAndLen [] = (-99, 0)+      yAndLen als@((PointUI _ y, _) : _) =+        (y, maximum $ map rightExtentOfLine als)+      lens = map yAndLen ovTop+      f2 = map g2+      g2 (p@(PointUI xstartRaw _), layerLine) =+        let xstart = if halveXstart then xstartRaw `div` 2 else xstartRaw+            available = width - xstart+        in (p, truncateAttrLine False available 0 layerLine)+  in concat $ if onBlank+              then map f2 ovTop+              else zipWith3 f ((-9, 0) : lens) (drop 1 lens ++ [(999, 0)]) ovTop++-- | Add a space at the message end, for display overlayed over the level map.+-- Also trim (do not wrap!) too long lines. Also add many spaces when under+-- longer lines.+truncateAttrLine :: Bool -> Int -> Int -> AttrLine -> AttrString+truncateAttrLine addSpaces available fillFromStart aLine =+  let al = attrLine aLine+      len = length al+  in if | null al -> if addSpaces+                     then replicate fillFromStart Color.spaceAttrW32+                     else al+        | len == available - 1 && addSpaces -> al ++ [Color.spaceAttrW32]+        | otherwise -> case compare available len of+            LT -> take (available - 1) al ++ [Color.trimmedLineAttrW32]+            GT | addSpaces ->+              let alSpace = al ++ [Color.spaceAttrW32, Color.spaceAttrW32]+                  whiteN = fillFromStart - len - 2+              in if whiteN <= 0+                 then alSpace  -- speedup (supposedly) for menus+                 else alSpace ++ replicate whiteN Color.spaceAttrW32+            _ -> al++-- | Overlays either the game map only or the whole empty screen frame.+-- We assume the lines of the overlay are not too long nor too many.+overlayFrame :: Int -> OverlaySpace -> PreFrame -> PreFrame+overlayFrame width ov (m, ff) =+  ( m+  , FrameForall $ \v -> do+      unFrameForall ff v+      mapM_ (\(PointUI px py, l) ->+               let offset = py * width + px `div` 2+               in unFrameForall (writeLine offset l) v) ov )
+ engine-src/Game/LambdaHack/Client/UI/FrameM.hs view
@@ -0,0 +1,270 @@+-- | A set of Frame monad operations.+module Game.LambdaHack.Client.UI.FrameM+  ( drawOverlay, promptGetKey, addToMacro, dropEmptyMacroFrames+  , lastMacroFrame, stopPlayBack, renderAnimFrames, animate+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , resetPlayBack, restoreLeaderFromRun, basicFrameForAnimation+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Bifunctor as B+import qualified Data.EnumMap.Strict as EM+import qualified Data.Map.Strict as M+import qualified Data.Vector.Unboxed as U++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.Animation+import           Game.LambdaHack.Client.UI.Content.Input+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.DrawM+import           Game.LambdaHack.Client.UI.Frame+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Definition.Color as Color++-- | Draw the current level with the overlay on top.+drawOverlay :: MonadClientUI m+            => ColorMode -> Bool -> FontOverlayMap -> LevelId+            -> m PreFrame3+drawOverlay dm onBlank ovs lid = do+  CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+  basicFrame <- if onBlank+                then do+                  let m = U.replicate (rwidth * rheight)+                                      (Color.attrCharW32 Color.spaceAttrW32)+                  return (m, FrameForall $ \_v -> return ())+                else drawHudFrame dm lid+  FontSetup{..} <- getFontSetup+  let propWidth = if isMonoFont propFont then 2 * rwidth else 4 * rwidth+      ovProp | not (isSquareFont propFont)+             = truncateOverlay False propWidth rheight False 0 onBlank+               $ EM.findWithDefault [] propFont ovs+             | otherwise = []+      ovMono = if not (isSquareFont monoFont)+               then truncateOverlay False (2 * rwidth) rheight False 0 onBlank+                    $ EM.findWithDefault [] monoFont ovs+               else []+      ovSquare | not (isSquareFont propFont)+               = truncateOverlay False (2 * rwidth) rheight False 0 onBlank+                 $ EM.findWithDefault [] squareFont ovs+              | otherwise = []+      ovOther | not (isSquareFont propFont) = []+              | otherwise+              = truncateOverlay True rwidth rheight True 20 onBlank+                $ concat $ EM.elems ovs+                    -- 20 needed not to leave gaps in skill menu+                    -- in the absence of backdrop+      ovBackdrop =+        if not (isSquareFont propFont) && not onBlank+        then let propOutline =+                   truncateOverlay False propWidth rheight True 0 onBlank+                   $ EM.findWithDefault [] propFont ovs+                 monoOutline =+                   truncateOverlay False (2 * rwidth) rheight True 0 onBlank+                   $ EM.findWithDefault [] monoFont ovs+                 squareOutline =+                   truncateOverlay False (2 * rwidth) rheight True 0 onBlank+                   $ EM.findWithDefault [] squareFont ovs+                 g x al Nothing = Just (x, x + length al - 1)+                 g x al (Just (xmin, xmax)) =+                   Just (min xmin x, max xmax (x + length al - 1))+                 f em (PointUI x y, al) = EM.alter (g x al) y em+                 extentMap = foldl' f EM.empty+                             $ propOutline ++ monoOutline ++ squareOutline+                 listBackdrop (y, (xmin, xmax)) =+                   ( PointUI (2 * (xmin `div` 2)) y+                   , blankAttrString+                     $ min (rwidth - 2 * (xmin `div` 2))+                           (1 + xmax `divUp` 2 - xmin `div` 2) )+             in map listBackdrop $ EM.assocs extentMap+        else []+      overlayedFrame = overlayFrame rwidth ovOther+                       $ overlayFrame rwidth ovBackdrop basicFrame+  return (overlayedFrame, (ovProp, ovSquare, ovMono))++promptGetKey :: MonadClientUI m+             => ColorMode -> FontOverlayMap -> Bool -> [K.KM]+             -> m K.KM+promptGetKey dm ovs onBlank frontKeyKeys = do+  lidV <- viewedLevelUI+  report <- getsSession $ newReport . shistory+  sreqQueried <- getsSession sreqQueried+  macroFrame <- getsSession smacroFrame+  let interrupted =+        -- If server is not querying for request, then the key is needed due to+        -- a special event, not ordinary querying the player for command,+        -- so interrupt.+        not sreqQueried+        -- Any alarming message interupts macros, except when the macro+        -- displays help and ends, which is a helpful thing to do.+        || (anyInReport disturbsResting report+            && keyPending macroFrame /= KeyMacro [K.mkKM "F1"])+  km <- case keyPending macroFrame of+    KeyMacro (km : kms) | not interrupted+                          -- A faulty key in a macro is a good reason+                          -- to interrupt it, as well.+                          && (null frontKeyKeys || km `elem` frontKeyKeys) -> do+      -- No need to display the frame, because a frame was displayed+      -- when the player chose to play a macro and each turn or more often+      -- a frame is displayed elsewhere.+      -- The only excepton is when navigating menus through macros,+      -- but there the speed is particularly welcome.+      modifySession $ \sess ->+        sess {smacroFrame = (smacroFrame sess) {keyPending = KeyMacro kms}}+      msgAdd MsgMacroOperation $ "Voicing '" <> tshow km <> "'."+      return km+    KeyMacro kms -> do+      if null kms then do+        -- There was no macro. Not important if there was a reason+        -- for interrupt or not.+        when (dm /= ColorFull) $ do+          -- This marks a special event, regardless of @sreqQueried@.+          side <- getsClient sside+          fact <- getsState $ (EM.! side) . sfactionD+          unless (gunderAI fact) -- don't forget special autoplay keypresses+            -- Forget the furious keypresses just before a special event.+            resetPressedKeys+        -- Running, if any, must have ended naturally, because no macro.+        -- Therefore no need to restore leader back to initial run leader,+        -- but running itself is cancelled below.+      else do+        -- The macro was not empty, but not played, so it must have been+        -- interrupted, so we can't continue playback, so wipe out the macro.+        resetPlayBack+        -- This might have been an unexpected end of a run, too.+        restoreLeaderFromRun+        -- Macro was killed, so emergency, so reset input, too.+        resetPressedKeys+      frontKeyFrame <- drawOverlay dm onBlank ovs lidV+      recordHistory+      modifySession $ \sess ->+        sess { srunning = Nothing+             , sxhairGoTo = Nothing+             , sdisplayNeeded = False+             , sturnDisplayed = True }+      connFrontendFrontKey frontKeyKeys frontKeyFrame+  -- In-game macros need to be recorded here, not in @UI.humanCommand@,+  -- to also capture choice of items from menus, etc.+  -- Notice that keys coming from macros (from content, in-game, config)+  -- are recorded as well and this is well defined and essential.+  --+  -- Only keys pressed when player is queried for a command are recorded.+  when sreqQueried $ do+    CCUI{coinput=InputContent{bcmdMap}} <- getsSession sccui+    modifySession $ \sess ->+      sess {smacroFrame = addToMacro bcmdMap km $ smacroFrame sess}+  return km++addToMacro :: M.Map K.KM HumanCmd.CmdTriple -> K.KM -> KeyMacroFrame+           -> KeyMacroFrame+addToMacro bcmdMap km macroFrame =+  case (\(_, _, cmd) -> cmd) <$> M.lookup km bcmdMap of+    Nothing -> macroFrame+    Just HumanCmd.Record -> macroFrame+    Just HumanCmd.RepeatLast{} -> macroFrame+    _ -> macroFrame { keyMacroBuffer =+                        (km :) `B.first` keyMacroBuffer macroFrame }+           -- This is noop when not recording a macro,+           -- which is exactly the required semantics.++dropEmptyMacroFrames :: KeyMacroFrame -> [KeyMacroFrame]+                     -> (KeyMacroFrame, [KeyMacroFrame])+dropEmptyMacroFrames mf [] = (mf, [])+dropEmptyMacroFrames (KeyMacroFrame _ (KeyMacro []) _)+                     (mf : mfs) = dropEmptyMacroFrames mf mfs+dropEmptyMacroFrames mf mfs = (mf, mfs)++lastMacroFrame :: KeyMacroFrame -> [KeyMacroFrame] -> KeyMacroFrame+lastMacroFrame mf [] = mf+lastMacroFrame _ (mf : mfs) = lastMacroFrame mf mfs++stopPlayBack :: MonadClientUI m => m ()+stopPlayBack = msgAdd MsgStopPlayback "!"++-- | We wipe any actions in progress, but keep the data needed to repeat+-- the last global macros and the last command.+resetPlayBack :: MonadClientUI m => m ()+resetPlayBack =+  modifySession $ \sess ->+    let lastFrame = lastMacroFrame (smacroFrame sess) (smacroStack sess)+    in sess { smacroFrame = lastFrame {keyPending = mempty}+            , smacroStack = [] }++restoreLeaderFromRun :: MonadClientUI m => m ()+restoreLeaderFromRun = do+  srunning <- getsSession srunning+  case srunning of+    Nothing -> return ()+    Just RunParams{runLeader} -> do+      -- Switch to the original leader, from before the run start,+      -- unless dead or unless the faction never runs with multiple+      -- (but could have the leader changed automatically meanwhile).+      side <- getsClient sside+      fact <- getsState $ (EM.! side) . sfactionD+      arena <- getArenaUI+      memA <- getsState $ memActor runLeader arena+      when (memA && not (noRunWithMulti fact)) $+        updateClientLeader runLeader++-- This is not our turn, so we can't obstruct screen with messages+-- and message reformatting causes distraction, so there's no point+-- trying to squeeze the report into the single available line,+-- except when it's not our turn permanently, because AI runs UI.+basicFrameForAnimation :: MonadClientUI m+                        => LevelId -> Maybe Bool -> m PreFrame3+basicFrameForAnimation arena forceReport = do+  FontSetup{propFont} <- getFontSetup+  sbenchMessages <- getsClient $ sbenchMessages . soptions+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  report <- getReportUI False+  let par1 = firstParagraph $ foldr (<+:>) [] $ renderReport True report+      -- If messages are benchmarked, they can't be displayed under AI,+      -- because this is not realistic when player is in control.+      truncRep | not sbenchMessages && fromMaybe (gunderAI fact) forceReport =+                   EM.fromList [(propFont, [(PointUI 0 0, par1)])]+               | otherwise = EM.empty+  drawOverlay ColorFull False truncRep arena++-- | Render animations on top of the current screen frame.+renderAnimFrames :: MonadClientUI m+                 => LevelId -> Animation -> Maybe Bool -> m PreFrames3+renderAnimFrames arena anim forceReport = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  snoAnim <- getsClient $ snoAnim . soptions+  basicFrame <- basicFrameForAnimation arena forceReport+  smuteMessages <- getsSession smuteMessages+  return $! if | smuteMessages -> []+               | fromMaybe False snoAnim -> [Just basicFrame]+               | otherwise -> map (fmap (\fr -> (fr, snd basicFrame)))+                              $ renderAnim rwidth (fst basicFrame) anim++-- | Render and display animations on top of the current screen frame.+animate :: MonadClientUI m => LevelId -> Animation -> m ()+animate arena anim = do+  -- The delay before reaction to keypress was too long in case of many+  -- projectiles hitting actors, so frames need to be skipped.+  keyPressed <- anyKeyPressed+  unless keyPressed $ do+    frames <- renderAnimFrames arena anim Nothing+    displayFrames arena frames
+ engine-src/Game/LambdaHack/Client/UI/Frontend.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE GADTs, KindSignatures, RankNTypes #-}+-- | Display game data on the screen and receive user input+-- using one of the available raw frontends and derived operations.+module Game.LambdaHack.Client.UI.Frontend+  ( -- * Connection and initialization+    FrontReq(..), ChanFrontend(..), chanFrontendIO+    -- * Re-exported part of the raw frontend+  , frontendName+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , FrontSetup, getKey, fchanFrontend, display, defaultMaxFps, microInSec+  , frameTimeoutThread, lazyStartup, nullStartup, seqFrame+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import           Control.Concurrent.Async+import qualified Control.Concurrent.STM as STM+import           Control.Monad.ST.Strict+import           Data.Kind (Type)+import qualified Data.Text.IO as T+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U+import           Data.Word+import           System.IO (hFlush, stdout)++import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Frontend.Teletype as Teletype+import           Game.LambdaHack.Client.UI.Key (KMP (..))+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.PointArray as PointArray+import qualified Game.LambdaHack.Definition.Color as Color++#ifdef USE_BROWSER+import qualified Game.LambdaHack.Client.UI.Frontend.Dom as Chosen+#else+import qualified Game.LambdaHack.Client.UI.Frontend.ANSI as ANSI+import qualified Game.LambdaHack.Client.UI.Frontend.Sdl as Chosen+#endif++-- | The instructions sent by clients to the raw frontend, indexed+-- by the returned value.+data FrontReq :: Type -> Type where+  -- | Show a frame.+  FrontFrame :: Frame -> FrontReq ()+  -- | Perform an explicit delay of the given length.+  FrontDelay :: Int -> FrontReq ()+  -- | Flush frames, display a frame and ask for a keypress.+  FrontKey :: [K.KM] -> Frame -> FrontReq KMP+  -- | Tell if a keypress is pending.+  FrontPressed :: FrontReq Bool+  -- | Discard a single key in the queue, if any.+  FrontDiscardKey :: FrontReq ()+  -- | Discard all keys in the queue.+  FrontResetKeys :: FrontReq ()+  -- | Shut the frontend down.+  FrontShutdown :: FrontReq ()+  -- | Take screenshot.+  FrontPrintScreen :: FrontReq ()++-- | Connection channel between a frontend and a client. Frontend acts+-- as a server, serving keys, etc., when given frames to display.+newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a)++-- | Machinery allocated for an individual frontend at its startup,+-- unchanged for its lifetime.+data FrontSetup = FrontSetup+  { fasyncTimeout :: Async ()+  , fdelay        :: MVar Int+  }++-- | Initialize the frontend chosen by the player via client options.+chanFrontendIO :: ScreenContent -> ClientOptions -> IO ChanFrontend+chanFrontendIO coscreen soptions = do+  let startup | sfrontendNull soptions = nullStartup coscreen+              | sfrontendLazy soptions = lazyStartup coscreen+#ifndef REMOVE_TELETYPE+              | sfrontendTeletype soptions = Teletype.startup coscreen+#endif+#ifndef USE_BROWSER+              | sfrontendANSI soptions = ANSI.startup coscreen+#endif+              | otherwise = Chosen.startup coscreen soptions+      maxFps = fromMaybe defaultMaxFps $ smaxFps soptions+      delta = max 1 $ round $ intToDouble microInSec / max 0.000001 maxFps+  rf <- startup+  when (sdbgMsgCli soptions) $ do+    T.hPutStr stdout "Frontend startup up.\n"+      -- hPutStrLn not atomic enough+    hFlush stdout+  fdelay <- newMVar 0+  fasyncTimeout <- async $ frameTimeoutThread delta fdelay rf+  -- Warning: not linking @fasyncTimeout@, so it'd better not crash.+  let fs = FrontSetup{..}+      chanFrontend = fchanFrontend fs rf+  return chanFrontend++-- Display a frame, wait for any of the specified keys (for any key,+-- if the list is empty). Repeat if an unexpected key received.+getKey :: FrontSetup -> RawFrontend -> [K.KM] -> Frame -> IO KMP+getKey fs rf@RawFrontend{fchanKey} keys frame = do+  -- Wait until timeout is up, not to skip the last frame of animation.+  display rf frame+  kmp <- STM.atomically $ STM.readTQueue fchanKey+  if null keys || kmpKeyMod kmp `elem` keys+  then return kmp+  else getKey fs rf keys frame++-- Read UI requests from the client and send them to the frontend,+fchanFrontend :: FrontSetup -> RawFrontend -> ChanFrontend+fchanFrontend fs@FrontSetup{..} rf =+  ChanFrontend $ \case+    FrontFrame frontFrame -> display rf frontFrame+    FrontDelay k -> modifyMVar_ fdelay $ return . (+ k)+    FrontKey frontKeyKeys frontKeyFrame ->+      getKey fs rf frontKeyKeys frontKeyFrame+    FrontPressed -> do+      noKeysPending <- STM.atomically $ STM.isEmptyTQueue (fchanKey rf)+      return $! not noKeysPending+    FrontDiscardKey ->+      void $ STM.atomically $ STM.tryReadTQueue (fchanKey rf)+    FrontResetKeys -> resetChanKey (fchanKey rf)+    FrontShutdown -> do+      cancel fasyncTimeout+      -- In case the last frame display is pending:+      void $ tryTakeMVar $ fshowNow rf+      fshutdown rf+    FrontPrintScreen -> fprintScreen rf++display :: RawFrontend -> Frame -> IO ()+display rf@RawFrontend{fshowNow, fcoscreen=ScreenContent{rwidth, rheight}}+        ((m, upd), (ovProp, ovSquare, ovMono)) = do+  let new :: forall s. ST s (G.Mutable U.Vector s Word32)+      new = do+        v <- unFrameBase m+        unFrameForall upd v+        return v+      singleArray = PointArray.Array rwidth rheight (U.create new)+  putMVar fshowNow () -- 1. wait for permission to display; 3. ack+  fdisplay rf $ SingleFrame singleArray ovProp ovSquare ovMono++defaultMaxFps :: Double+defaultMaxFps = 24++microInSec :: Int+microInSec = 1000000++-- This thread is canceled forcefully, because the @threadDelay@+-- may be much longer than an acceptable shutdown time.+frameTimeoutThread :: Int -> MVar Int -> RawFrontend -> IO ()+frameTimeoutThread delta fdelay RawFrontend{..} = do+  let loop = do+        threadDelay delta+        let delayLoop = do+              delay <- readMVar fdelay+              when (delay > 0) $ do+                threadDelay $ delta * delay+                modifyMVar_ fdelay $ return . subtract delay+                delayLoop+        delayLoop+        let showFrameAndRepeatIfKeys = do+              -- @fshowNow@ is full at this point, unless @saveKM@ emptied it,+              -- in which case we wait below until @display@ fills it+              takeMVar fshowNow  -- 2. permit display+              -- @fshowNow@ is ever empty only here, unless @saveKM@ empties it+              readMVar fshowNow  -- 4. wait for ack before starting delay+              -- @fshowNow@ is full at this point+              noKeysPending <- STM.atomically $ STM.isEmptyTQueue fchanKey+              unless noKeysPending $ do+                void $ swapMVar fdelay 0  -- cancel delays lest they accumulate+                showFrameAndRepeatIfKeys+        showFrameAndRepeatIfKeys+        loop+  loop++-- | The name of the chosen frontend.+frontendName :: ClientOptions -> String+frontendName soptions =+  if | sfrontendNull soptions -> "null test"+     | sfrontendLazy soptions -> "lazy test"+#ifndef REMOVE_TELETYPE+     | sfrontendTeletype soptions -> Teletype.frontendName+#endif+#ifndef USE_BROWSER+     | sfrontendANSI soptions -> ANSI.frontendName+#endif+     | otherwise -> Chosen.frontendName++lazyStartup :: ScreenContent -> IO RawFrontend+lazyStartup coscreen = createRawFrontend coscreen (\_ -> return ()) (return ())++nullStartup :: ScreenContent -> IO RawFrontend+nullStartup coscreen = createRawFrontend coscreen seqFrame (return ())++seqFrame :: SingleFrame -> IO ()+seqFrame SingleFrame{..} =+  let seqAttr () attr = Color.colorToRGB (Color.fgFromW32 attr)+                        `seq` Color.bgFromW32 attr+                        `seq` Color.charFromW32 attr == ' '+                        `seq` ()+      !_Force1 = PointArray.foldlA' seqAttr () singleArray+      !_Force2 = length singlePropOverlay+      !_Force3 = length singleSquareOverlay+      !_Force4 = length singleMonoOverlay+  in return ()
+ engine-src/Game/LambdaHack/Client/UI/Frontend/ANSI.hs view
@@ -0,0 +1,318 @@+-- | Text frontend based on ANSI (via ansi-terminal).+module Game.LambdaHack.Client.UI.Frontend.ANSI+  ( startup, frontendName+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent.Async+import           Data.Char (chr, ord)+import qualified Data.Text as T+import qualified System.Console.ANSI as ANSI+import           System.Exit (die)+import qualified System.IO as SIO++import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Content.TileKind (floorSymbol)+import qualified Game.LambdaHack.Definition.Color as Color++-- No session data maintained by this frontend++-- | The name of the frontend.+frontendName :: String+frontendName = "ANSI"++-- | Starts the main program loop using the frontend input and output.+startup :: ScreenContent -> IO RawFrontend+startup coscreen@ScreenContent{rwidth, rheight} = do+  ANSI.clearScreen+  myx <- ANSI.getTerminalSize+  case myx of+    Just (y, x) | x < rwidth || y < rheight ->+      -- Unlike @error@, @die@ does not move savefiles aside.+      die $ T.unpack $+        "The terminal is too small. It should have"+        <+> tshow rwidth+        <+> "columns and"+        <+> tshow rheight+        <+> "rows, but is has"+        <+> tshow x+        <+> "columns and"+        <+> tshow y+        <+> "rows. Resize it and run the program again."+    _ -> do+      rf <- createRawFrontend coscreen (display coscreen) (shutdown coscreen)+      let storeKeys :: IO ()+          storeKeys = do+            c <- SIO.getChar  -- blocks here, so no polling+            s <- do+              if c == '\ESC' then do+                ready <- SIO.hReady SIO.stdin+                if ready then do+                  c2 <- SIO.getChar+                  case c2 of+                    '\ESC' -> return [c]+                    '[' -> keycodeInput [c, c2]+                    'O' -> keycodeInput [c, c2]+                    _ -> return [c, c2]  -- Alt modifier+                else return [c]+              else return [c]+            let K.KM{..} = keyTranslate s+            saveKMP rf modifier key (PointUI 0 0)+            storeKeys+          keycodeInput :: String -> IO String+          keycodeInput inputSoFar = do+            ready <- SIO.hReady SIO.stdin+            if ready then do+              c <- SIO.getChar+              if ord '@' <= ord c && ord c <= ord '~'  -- terminator+              then return $ inputSoFar ++ [c]+              else keycodeInput  $ inputSoFar ++ [c]+            else return inputSoFar+      SIO.hSetBuffering SIO.stdin SIO.NoBuffering+      SIO.hSetBuffering SIO.stderr $ SIO.BlockBuffering $+        Just $ 2 * rwidth * rheight+      void $ async storeKeys+      return $! rf++-- This is contrived, because we don't want to depend on libraries+-- that read and interpret terminfo or similar on different architectures.+-- The "works" comments are mostly about Gnome terminal.+-- On the Gnome terminal, fo the keys mention on game help screen,+-- the following don't work: C-TAB, C-S-TAB, C-R, C-?. C-/, C-{, C-}, C-q,+-- C-S, C-P, C-keypad. This is acceptable. No worth adding functionality+-- for decoding modifiers that would, with much luck, enable C-keypad,+-- but no other broken keys. Unless more is broken on other terminals.+-- On rxvt, sadly, KP_5 is a dead key.+keyTranslate :: String -> K.KM+keyTranslate e = (\(key, modifier) -> K.KM modifier key) $+  case e of+    "\ESC" -> (K.Esc, K.NoModifier)  -- equals @^[@+    '\ESC' : '[' : rest -> keycodeTranslate rest+    '\ESC' : 'O' : rest -> ocodeTranslate rest+    ['\ESC', c] -> (K.Char c, K.Alt)+    "\b" -> (K.BackSpace, K.NoModifier)  -- same as "\BS" and "\^H" but fails+    "\DEL" -> (K.BackSpace, K.NoModifier)  -- works; go figure+    "\n" -> (K.Return, K.NoModifier)+    "\r" -> (K.Return, K.NoModifier)+    " "  -> (K.Space, K.NoModifier)+    "\t" -> (K.Tab, K.NoModifier)  -- apparently equals @\^I@ and @\HT@+    [c] | ord '\^A' <= ord c && ord c <= ord '\^Z' ->+          -- Alas, only lower-case letters.+          (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)+        | -- On (some) terminal emulators Shift-keypad direction produces+          -- the same code as number keys. A sensible workaround for that+          -- is using Control for running, but it's not clear how portable+          -- this is, so we do not rely on this exclusively. Since movement+          -- keys are more important than leader picking, we are disabling+          -- the latter and interpreting the keypad numbers as movement.+          --+          -- BTW, S-KP_5 and C-KP_5 are probably still not correctly handled+          -- on some terminals, so this may be the biggest portability problem.+          c `elem` ['1'..'9'] -> (K.KP c, K.NoModifier)+        | otherwise           -> (K.Char c, K.NoModifier)+    _ -> (K.Unknown e, K.NoModifier)++-- From https://en.wikipedia.org/wiki/ANSI_escape_code#Terminal_input_sequences+keycodeTranslate :: String -> (K.Key, K.Modifier)+keycodeTranslate e =+  case e of+    "1~" -> (K.Home, K.NoModifier)+    "2~" -> (K.Insert, K.NoModifier)+    "3~" -> (K.Delete, K.NoModifier)+    "4~" -> (K.End , K.NoModifier)+    "5~" -> (K.PgUp, K.NoModifier)+    "6~" -> (K.PgDn, K.NoModifier)+    "7~" -> (K.Home, K.NoModifier)+    "8~" -> (K.End, K.NoModifier)+    "9~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "10~" -> (K.Fun 0, K.NoModifier)+    "11~" -> (K.Fun 1, K.NoModifier)+    "12~" -> (K.Fun 2, K.NoModifier)+    "13~" -> (K.Fun 3, K.NoModifier)+    "14~" -> (K.Fun 4, K.NoModifier)+    "15~" -> (K.Fun 5, K.NoModifier)+    "17~" -> (K.Fun 6, K.NoModifier)+    "18~" -> (K.Fun 7, K.NoModifier)+    "19~" -> (K.Fun 8, K.NoModifier)+    "20~" -> (K.Fun 9, K.NoModifier)+    "21~" -> (K.Fun 10, K.NoModifier)+    "22~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "23~" -> (K.Fun 11, K.NoModifier)+    "24~" -> (K.Fun 12, K.NoModifier)+    "25~" -> (K.Fun 13, K.NoModifier)+    "26~" -> (K.Fun 14, K.NoModifier)+    "27~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "28~" -> (K.Fun 15, K.NoModifier)+    "29~" -> (K.Fun 16, K.NoModifier)+    "30~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "32~" -> (K.Fun 18 , K.NoModifier)+    "33~" -> (K.Fun 19 , K.NoModifier)+    "34~" -> (K.Fun 20 , K.NoModifier)+    "35~" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)++    "A" -> (K.Up, K.NoModifier)+    "B" -> (K.Down, K.NoModifier)+    "C" -> (K.Right, K.NoModifier)+    "D" -> (K.Left, K.NoModifier)+    "E" -> (K.Begin, K.NoModifier)+    "F" -> (K.End, K.NoModifier)+    "G" -> (K.KP '5', K.NoModifier)+    "H" -> (K.Home, K.NoModifier)+    "I" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "J" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "K" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "L" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "M" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "N" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "O" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "1P" -> (K.Fun 1, K.NoModifier)+    "1Q" -> (K.Fun 2, K.NoModifier)+    "1R" -> (K.Fun 3, K.NoModifier)+    "1S" -> (K.Fun 4, K.NoModifier)+    "T" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "U" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "V" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "W" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "X" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "Y" -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)+    "Z" -> (K.BackTab, K.NoModifier)++--    "r" -> (K.Begin, K.NoModifier)+--    "u" -> (K.Begin, K.NoModifier)++    _ -> (K.Unknown $ "\\ESC[" ++ e, K.NoModifier)++-- From guesswork, cargo-culting and @sed -n l@.+ocodeTranslate :: String -> (K.Key, K.Modifier)+ocodeTranslate e =+  case e of+    "P" -> (K.Fun 1, K.NoModifier)+    "Q" -> (K.Fun 2, K.NoModifier)+    "R" -> (K.Fun 3, K.NoModifier)+    "S" -> (K.Fun 4, K.NoModifier)++    "p" -> (K.KP '0', K.Shift)+    "q" -> (K.KP '1', K.Shift)+    "r" -> (K.KP '2', K.Shift)+    "s" -> (K.KP '3', K.Shift)+    "t" -> (K.KP '4', K.Shift)+    "u" -> (K.KP '5', K.Shift)+    "v" -> (K.KP '6', K.Shift)+    "w" -> (K.KP '7', K.Shift)+    "x" -> (K.KP '8', K.Shift)+    "y" -> (K.KP '9', K.Shift)++    _ -> (K.Unknown $ "\\ESCO" ++ e, K.NoModifier)++shutdown :: ScreenContent -> IO ()+shutdown ScreenContent{rheight} = do+  -- The lowest position guaranteed to exist.+  ANSI.hSetCursorPosition SIO.stderr (rheight - 1) 0+  SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr++-- | Output to the screen via the frontend.+display :: ScreenContent+        -> SingleFrame+        -> IO ()+display ScreenContent{rwidth} SingleFrame{singleArray} = do+  ANSI.hHideCursor SIO.stderr+  let cutInChunks [] = []+      cutInChunks l = let (ch, r) = splitAt rwidth l+                      in ch : cutInChunks r+      f (!y, chunk) = do+        ANSI.hSetCursorPosition SIO.stderr y 0+        SIO.hPutStr SIO.stderr $ g chunk+      g = concatMap h+      -- Not emitting ANSI if the previous character had the same fg and bg+      -- gains little in terms of maximal lag, due to checkerboard levels/rooms+      -- (even though it triples FPS in normal rooms; but comparing with+      -- previous frame gains even more in normal cases and copes well+      -- with checkerboard; both not worth the effort for this frontend).+      h !w =+        let acChar = squashChar $ Color.charFromW32 w+            (fg, bg) = setAttr $ Color.attrFromW32 w+        in ANSI.setSGRCode [ uncurry (ANSI.SetColor ANSI.Foreground)+                             $ colorTranslate fg+                           , uncurry (ANSI.SetColor ANSI.Background)+                             $ colorTranslate bg ]+           ++ [acChar]+{-+This is dubious, because I can't force bright background colour with that,+only bright foregrounds. And I have at least one bright backround: bright black.+        -- 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, in Vty you have to request the hack,+        -- with ANSI we probably need it as well.+        ANSI.hSetSGR SIO.stderr [ANSI.SetConsoleIntensity+                                 $ if Color.isBright fg+                                   then ANSI.BoldIntensity+                                   else ANSI.NormalIntensity]+-}+  mapM_ f $ zip [0 ..] $ cutInChunks $ PointArray.toListA singleArray+  let Point{..} = PointArray.maxIndexByA (comparing Color.bgFromW32) singleArray+  ANSI.hSetCursorPosition SIO.stderr py px+  ANSI.hShowCursor SIO.stderr+  -- Do not trash people's terminals when interrupted:+  ANSI.hSetSGR SIO.stderr [uncurry (ANSI.SetColor ANSI.Foreground)+                           $ colorTranslate Color.White]+  ANSI.hSetSGR SIO.stderr [uncurry (ANSI.SetColor ANSI.Background)+                           $ colorTranslate Color.Black]+  SIO.hFlush SIO.stderr++squashChar :: Char -> Char+squashChar c = if c == floorSymbol then '.' else c++setAttr :: Color.Attr -> (Color.Color, Color.Color)+setAttr Color.Attr{..} =+  let (fg1, bg1) = case bg of+        Color.HighlightNone -> (fg, Color.Black)+        Color.HighlightWhite ->+          if fg /= Color.Magenta+          then (fg, Color.Magenta)+          else (fg, Color.BrBlack)+        Color.HighlightRed ->+          if fg /= Color.Red+          then (fg, Color.Red)+          else (fg, Color.defFG)+        Color.HighlightYellow -> (fg, Color.Black)  -- cursor used instead+        Color.HighlightYellowAim -> (Color.Black, Color.defFG)+        Color.HighlightRedAim ->+          if fg /= Color.Red+          then (fg, Color.Red)+          else (fg, Color.defFG)+        Color.HighlightNoneCursor -> (fg, Color.Black)+        _ -> if fg /= Color.highlightToColor bg+             then (fg, Color.highlightToColor bg)+             else (fg, if fg == Color.BrBlack+                       then Color.Black+                       else Color.BrBlack)+  in (fg1, bg1)++colorTranslate :: Color.Color -> (ANSI.ColorIntensity, ANSI.Color)+colorTranslate Color.Black     = (ANSI.Dull, ANSI.Black)+colorTranslate Color.Red       = (ANSI.Dull, ANSI.Red)+colorTranslate Color.Green     = (ANSI.Dull, ANSI.Green)+colorTranslate Color.Brown     = (ANSI.Dull, ANSI.Yellow)+colorTranslate Color.Blue      = (ANSI.Dull, ANSI.Blue)+colorTranslate Color.Magenta   = (ANSI.Dull, ANSI.Magenta)+colorTranslate Color.Cyan      = (ANSI.Dull, ANSI.Cyan)+colorTranslate Color.White     = (ANSI.Dull, ANSI.White)+colorTranslate Color.AltWhite  = (ANSI.Dull, ANSI.White)+colorTranslate Color.BrBlack   = (ANSI.Vivid, ANSI.Black)+colorTranslate Color.BrRed     = (ANSI.Vivid, ANSI.Red)+colorTranslate Color.BrGreen   = (ANSI.Vivid, ANSI.Green)+colorTranslate Color.BrYellow  = (ANSI.Vivid, ANSI.Yellow)+colorTranslate Color.BrBlue    = (ANSI.Vivid, ANSI.Blue)+colorTranslate Color.BrMagenta = (ANSI.Vivid, ANSI.Magenta)+colorTranslate Color.BrCyan    = (ANSI.Vivid, ANSI.Cyan)+colorTranslate Color.BrWhite   = (ANSI.Vivid, ANSI.White)
+ engine-src/Game/LambdaHack/Client/UI/Frontend/Common.hs view
@@ -0,0 +1,94 @@+-- | Screen frames and animations.+module Game.LambdaHack.Client.UI.Frontend.Common+  ( RawFrontend(..)+  , startupBound, createRawFrontend, resetChanKey, saveKMP+  , modifierTranslate+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import qualified Control.Concurrent.STM as STM++import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.Key (KMP (..))+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Common.Misc++-- | Raw frontend definition. The minimal closed set of values that need+-- to depend on the specifics of the chosen frontend.+data RawFrontend = RawFrontend+  { fdisplay     :: SingleFrame -> IO ()+  , fshutdown    :: IO ()+  , fshowNow     :: MVar ()+  , fchanKey     :: STM.TQueue KMP+  , fprintScreen :: IO ()+  , fcoscreen    :: ScreenContent+  }++-- | Start up a frontend on a bound thread.+--+-- In fact, it is started on the very main thread, via a hack, because+-- apparently some SDL backends are not thread-safe+-- (<https://wiki.libsdl.org/FAQDevelopment>;+-- "this should only be run in the thread that initialized the video subsystem,+-- and for extra safety, you should consider only doing those things+-- on the main thread in any case")+-- and at least the newer OS X obtusely requires the main thread, see+-- https://github.com/AllureOfTheStars/Allure/issues/79+-- In case any other exotic architecture requires the main thread,+-- we make the hack the default for all (on frontends that require a bound+-- thread, e.g., SLD2).+startupBound :: (MVar RawFrontend -> IO ()) -> IO RawFrontend+startupBound k = do+  rfMVar <- newEmptyMVar+  putMVar workaroundOnMainThreadMVar $ k rfMVar+  -- The following would run frontend on a bound thread, but it's not enough:+  -- a <- asyncBound $ k rfMVar+  -- link a+  takeMVar rfMVar++createRawFrontend :: ScreenContent -> (SingleFrame -> IO ()) -> IO ()+                  -> IO RawFrontend+createRawFrontend fcoscreen fdisplay fshutdown = do+  -- Set up the channel for keyboard input.+  fchanKey <- STM.atomically STM.newTQueue+  -- Create the session record.+  fshowNow <- newEmptyMVar+  return $! RawFrontend+    { fdisplay+    , fshutdown+    , fshowNow+    , fchanKey+    , fprintScreen = return ()  -- dummy, except for SDL2+    , fcoscreen+    }++-- | Empty the keyboard channel.+resetChanKey :: STM.TQueue KMP -> IO ()+resetChanKey fchanKey = do+  res <- STM.atomically $ STM.tryReadTQueue fchanKey+  when (isJust res) $ resetChanKey fchanKey++saveKMP :: RawFrontend -> K.Modifier -> K.Key -> PointUI -> IO ()+saveKMP !rf !modifier !key !kmpPointer = do+  -- Instantly show any frame waiting for display.+  void $ tryTakeMVar $ fshowNow rf+  let kmp = KMP{kmpKeyMod = K.KM{..}, kmpPointer}+  unless (key == K.DeadKey) $+    -- Store the key in the channel.+    STM.atomically $ STM.writeTQueue (fchanKey rf) kmp++-- | Translates modifiers to our own encoding.+modifierTranslate :: Bool -> Bool -> Bool -> Bool -> K.Modifier+modifierTranslate modCtrl modShift modAlt modMeta+  | (modAlt || modMeta) && modShift = K.AltShift+  | modAlt || modMeta = K.Alt+  | modCtrl && modShift = K.ControlShift+  | modCtrl = K.Control+  | modShift = K.Shift+  | otherwise = K.NoModifier
+ engine-src/Game/LambdaHack/Client/UI/Frontend/Dom.hs view
@@ -0,0 +1,283 @@+-- | Text frontend running in a browser.+module Game.LambdaHack.Client.UI.Frontend.Dom+  (+#ifdef USE_BROWSER+-- to molify doctest, but don't break stylish-haskell parsing+   startup, frontendName+#endif+  ) where++#ifdef USE_BROWSER+import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import qualified Control.Monad.IO.Class as IO+import           Control.Monad.Trans.Reader (ask)+import           Data.IORef+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import           Data.Word (Word32)++import GHCJS.DOM (currentDocument, currentWindow)+import GHCJS.DOM.CSSStyleDeclaration (setProperty)+import GHCJS.DOM.Document (createElement, getBodyUnchecked)+import GHCJS.DOM.Element (Element (Element), setInnerHTML)+import GHCJS.DOM.ElementCSSInlineStyle (getStyle)+import GHCJS.DOM.EventM+  ( EventM+  , mouseAltKey+  , mouseButton+  , mouseCtrlKey+  , mouseMetaKey+  , mouseShiftKey+  , on+  , preventDefault+  , stopPropagation+  )+import GHCJS.DOM.GlobalEventHandlers (contextMenu, keyDown, mouseUp, wheel)+import GHCJS.DOM.HTMLCollection (itemUnsafe)+import GHCJS.DOM.HTMLElement (focus)+import GHCJS.DOM.HTMLTableElement+  (HTMLTableElement (HTMLTableElement), getRows, setCellPadding, setCellSpacing)+import GHCJS.DOM.HTMLTableRowElement+  (HTMLTableRowElement (HTMLTableRowElement), getCells)+import GHCJS.DOM.KeyboardEvent+  (getAltGraphKey, getAltKey, getCtrlKey, getKey, getMetaKey, getShiftKey)+import GHCJS.DOM.Node (appendChild_, replaceChild_, setTextContent)+import GHCJS.DOM.NonElementParentNode (getElementByIdUnsafe)+import GHCJS.DOM.RequestAnimationFrameCallback+import GHCJS.DOM.Types+  ( CSSStyleDeclaration+  , DOM+  , HTMLDivElement (HTMLDivElement)+  , HTMLTableCellElement (HTMLTableCellElement)+  , IsMouseEvent+  , JSString+  , Window+  , runDOM+  , unsafeCastTo+  )+import GHCJS.DOM.WheelEvent (getDeltaY)+import GHCJS.DOM.Window (requestAnimationFrame_)++import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Content.TileKind (floorSymbol)+import qualified Game.LambdaHack.Definition.Color as Color++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { scurrentWindow :: Window+  , scharCells     :: V.Vector (HTMLTableCellElement, CSSStyleDeclaration)+  , spreviousFrame :: IORef SingleFrame+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "browser"++-- | Starts the main program loop using the frontend input and output.+startup :: ScreenContent -> ClientOptions -> IO RawFrontend+startup coscreen soptions = do+  rfMVar <- newEmptyMVar+  flip runDOM undefined $ runWeb coscreen soptions rfMVar+  takeMVar rfMVar++runWeb :: ScreenContent -> ClientOptions -> MVar RawFrontend -> DOM ()+runWeb coscreen ClientOptions{..} rfMVar = do+  -- Init the document.+  Just doc <- currentDocument+  Just scurrentWindow <- currentWindow+  body <- getBodyUnchecked doc+  pageStyle <- getStyle body+  setProp pageStyle "background-color" (Color.colorToRGB Color.Black)+  setProp pageStyle "color" (Color.colorToRGB Color.AltWhite)+  -- Create the session record.+  divBlockRaw <- createElement doc ("div" :: Text)+  divBlock <- unsafeCastTo HTMLDivElement divBlockRaw+  let cell = "<td>\x00a0"+      row = "<tr>" ++ concat (replicate (rwidth coscreen) cell)+      rows = concat (replicate (rheight coscreen) row)+  tableElemRaw <- createElement doc ("table" :: Text)+  tableElem <- unsafeCastTo HTMLTableElement tableElemRaw+  -- Get rid of table spacing. Spurious hacks just in case.+  setCellPadding tableElem ("0" :: Text)+  setCellSpacing tableElem ("0" :: Text)+  appendChild_ divBlock tableElem+  setInnerHTML tableElem rows+  scharCells <- flattenTable coscreen tableElem+  spreviousFrame <- newIORef $ blankSingleFrame coscreen+  let sess = FrontendSession{..}+  rf <- IO.liftIO $ createRawFrontend coscreen (display sess) shutdown+  let readMod = do+        modCtrl <- ask >>= getCtrlKey+        modShift <- ask >>= getShiftKey+        modAlt <- ask >>= getAltKey+        modMeta <- ask >>= getMetaKey+        modAltG <- ask >>= getAltGraphKey+        return $! modifierTranslate modCtrl modShift (modAlt || modAltG) modMeta+  gameMap <- getElementByIdUnsafe doc ("gameMap" :: Text)+  divMap <- unsafeCastTo HTMLDivElement gameMap+  focus divMap+  void $ divMap `on` keyDown $ do+    keyId <- ask >>= getKey+    modifier <- readMod+--  This is currently broken at least for Shift-F1, etc., so won't be used:+--    keyLoc <- ask >>= getKeyLocation+--    let onKeyPad = case keyLoc of+--          3 {-KEY_LOCATION_NUMPAD-} -> True+--          _ -> False+    let key = K.keyTranslateWeb keyId (modifier == K.Shift)+        modifierNoShift = case modifier of  -- to prevent S-!, etc.+          K.Shift -> K.NoModifier+          K.ControlShift -> K.Control+          K.AltShift -> K.Alt+          _ -> modifier+    -- IO.liftIO $ do+    --   putStrLn $ "keyId: " ++ keyId+    --   putStrLn $ "key: " ++ K.showKey key+    --   putStrLn $ "modifier: " ++ show modifier+    when (key == K.Esc) $ IO.liftIO $ resetChanKey (fchanKey rf)+    IO.liftIO $ saveKMP rf modifierNoShift key (PointUI 0 0)+    -- Pass through C-+ and others, but disable special behaviour on Tab, etc.+    let browserKeys = "+-0tTnNdxcv"+    unless (modifier == K.Alt+            || modifier == K.Control && key `elem` map K.Char browserKeys+            || key == K.DeadKey) $ do  -- NumLock in particular+      preventDefault+      stopPropagation+  -- Handle mouseclicks, per-cell.+  let setupMouse i a =+        let Point{..} = punindex (rwidth coscreen) i+              -- abuse of convention in that @Point@ used for screen, not map+            pUI = squareToUI $ PointSquare px py+        in handleMouse rf a pUI+  V.imapM_ setupMouse scharCells+  -- Display at the end to avoid redraw. Replace "Please wait".+  pleaseWait <- getElementByIdUnsafe doc ("pleaseWait" :: Text)+  replaceChild_ gameMap divBlock pleaseWait+  IO.liftIO $ putMVar rfMVar rf+    -- send to client only after the whole webpage is set up+    -- because there is no @mainGUI@ to start accepting++shutdown :: IO ()+shutdown = return () -- nothing to clean up++setProp :: CSSStyleDeclaration -> JSString -> Text -> DOM ()+setProp style propRef propValue =+  setProperty style propRef propValue (Nothing :: Maybe JSString)++-- | Let each table cell handle mouse events inside.+handleMouse :: RawFrontend+            -> (HTMLTableCellElement, CSSStyleDeclaration) -> PointUI+            -> DOM ()+handleMouse rf (cell, _) pUI = do+  let readMod :: IsMouseEvent e => EventM HTMLTableCellElement e K.Modifier+      readMod = do+        modCtrl <- mouseCtrlKey+        modShift <- mouseShiftKey+        modAlt <- mouseAltKey+        modMeta <- mouseMetaKey+        return $! modifierTranslate modCtrl modShift modAlt modMeta+      saveWheel = do+        wheelY <- ask >>= getDeltaY+        modifier <- readMod+        let mkey = if | wheelY < -0.01 -> Just K.WheelNorth+                      | wheelY > 0.01 -> Just K.WheelSouth+                      | otherwise -> Nothing  -- probably a glitch+        maybe (return ())+              (\key -> IO.liftIO $ saveKMP rf modifier key pUI) mkey+      saveMouse = do+        -- <https://hackage.haskell.org/package/ghcjs-dom-0.2.1.0/docs/GHCJS-DOM-EventM.html>+        but <- mouseButton+        modifier <- readMod+        let key = case but of+              0 -> K.LeftButtonRelease+              1 -> K.MiddleButtonRelease+              2 -> K.RightButtonRelease  -- not handled in contextMenu+              _ -> K.LeftButtonRelease  -- any other is alternate left+        -- IO.liftIO $ putStrLn $+        --   "m: " ++ show but ++ show modifier ++ show pUI+        IO.liftIO $ saveKMP rf modifier key pUI+  void $ cell `on` wheel $ do+    saveWheel+    preventDefault+    stopPropagation+  void $ cell `on` contextMenu $ do+    preventDefault+    stopPropagation+  void $ cell `on` mouseUp $ do+    saveMouse+    preventDefault+    stopPropagation++-- | Get the list of all cells of an HTML table.+flattenTable :: ScreenContent+             -> HTMLTableElement+             -> DOM (V.Vector (HTMLTableCellElement, CSSStyleDeclaration))+flattenTable coscreen table = do+  rows <- getRows table+  let f y = do+        rowsItem <- itemUnsafe rows y+        unsafeCastTo HTMLTableRowElement rowsItem+  lrow <- mapM f [0 .. toEnum (rheight coscreen - 1)]+  let getC :: HTMLTableRowElement+           -> DOM [(HTMLTableCellElement, CSSStyleDeclaration)]+      getC row = do+        cells <- getCells row+        let g x = do+              cellsItem <- itemUnsafe cells x+              cell <- unsafeCastTo HTMLTableCellElement cellsItem+              style <- getStyle cell+              return (cell, style)+        mapM g [0 .. toEnum (rwidth coscreen - 1)]+  lrc <- mapM getC lrow+  return $! V.fromListN (rwidth coscreen * rheight coscreen) $ concat lrc++-- | Output to the screen via the frontend.+display :: FrontendSession  -- ^ frontend session data+        -> SingleFrame  -- ^ the screen frame to draw+        -> IO ()+display FrontendSession{..} !curFrame = flip runDOM undefined $ do+  let setChar :: Int -> (Word32, Word32) -> DOM Int+      setChar !i (!w, !wPrev) | w == wPrev = return $! i + 1+      setChar i (w, wPrev) = do+        let Point{..} = toEnum i+            Color.AttrChar{acAttr=Color.Attr{fg=fgRaw,bg}, acChar} =+              Color.attrCharFromW32 $ Color.AttrCharW32 w+            fg | even py && fgRaw == Color.White = Color.AltWhite+               | otherwise = fgRaw+            (!cell, !style) = scharCells V.! i+        if | acChar == ' ' -> setTextContent cell $ Just ("\x00a0" :: JSString)+           | acChar == floorSymbol && not (Color.isBright fg) ->+             setTextContent cell $ Just ("\x22C5" :: JSString)+           | otherwise -> setTextContent cell $ Just [acChar]+        setProp style "color" $ Color.colorToRGB fg+        let bgPrev = Color.bgFromW32 $ Color.AttrCharW32 wPrev+        when (bg /= bgPrev) $ do+          let background = if bg == Color.HighlightBackground+                           then "#251F1F"+                           else Color.colorToRGB Color.Black+          setProp style "background-color" background+          setProp style "border-color"+                        (Color.colorToRGB $ Color.highlightToColor bg)+        return $! i + 1+  !prevFrame <- readIORef spreviousFrame+  writeIORef spreviousFrame curFrame+  -- This continues asynchronously, if can't otherwise.+  callback <- newRequestAnimationFrameCallbackSync $ \_ ->+    U.foldM'_ setChar 0 $ U.zip (PointArray.avector $ singleArray curFrame)+                                (PointArray.avector $ singleArray prevFrame)+  -- This attempts to ensure no redraws while callback executes+  -- and a single redraw when it completes.+  requestAnimationFrame_ scurrentWindow callback+#endif
+ engine-src/Game/LambdaHack/Client/UI/Frontend/Sdl.hs view
@@ -0,0 +1,922 @@+-- | Text frontend based on SDL2.+module Game.LambdaHack.Client.UI.Frontend.Sdl+  ( startup, frontendName+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , FontAtlas, FrontendSession(..), startupFun, shutdown, forceShutdown+  , display, drawFrame, printScreen, modTranslate, keyTranslate, colorToRGBA+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import           Data.IORef+import qualified Data.Text as T+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as U+import           Data.Word (Word32, Word8)+import           Foreign.C.String (withCString)+import           Foreign.C.Types (CInt)+import           Foreign.Ptr (nullPtr)+import           Foreign.Storable (peek)+import           System.Directory+import           System.Exit (die, exitSuccess)+import           System.FilePath++import qualified SDL+import qualified SDL.Font as TTF+import           SDL.Input.Keyboard.Codes+import qualified SDL.Internal.Types+import qualified SDL.Raw.Basic as SDL (logSetAllPriority)+import qualified SDL.Raw.Enum+import qualified SDL.Raw.Event+import qualified SDL.Raw.Types+import qualified SDL.Raw.Video+import qualified SDL.Vect as Vect++import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.File+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Content.TileKind (floorSymbol)+import qualified Game.LambdaHack.Definition.Color as Color++-- These are needed until SDL is fixed and all our devs move+-- to the fixed version:+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           SDL.Internal.Exception (throwIfNull)+import qualified SDL.Raw.Event as Raw+import           Unsafe.Coerce (unsafeCoerce)+--import qualified SDL.Raw.Enum as Raw++type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { swindow          :: SDL.Window+  , srenderer        :: SDL.Renderer+  , squareFont       :: TTF.Font+  , squareFontSize   :: Int+  , mapFontIsBitmap  :: Bool+  , spropFont        :: Maybe TTF.Font+  , sboldFont        :: Maybe TTF.Font+  , smonoFont        :: Maybe TTF.Font+  , squareAtlas      :: IORef FontAtlas+  , smonoAtlas       :: IORef FontAtlas+  , sbasicTexture    :: IORef SDL.Texture+  , stexture         :: IORef SDL.Texture+  , spreviousFrame   :: IORef SingleFrame+  , sforcedShutdown  :: IORef Bool+  , scontinueSdlLoop :: IORef Bool+  , sframeQueue      :: MVar SingleFrame+  , sframeDrawn      :: MVar ()+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "sdl"++-- | Set up and start the main loop providing input and output.+--+-- Because of Windows and OS X, SDL2 needs to be on a bound thread,+-- so we can't avoid the communication overhead of bound threads.+startup :: ScreenContent -> ClientOptions -> IO RawFrontend+startup coscreen soptions = startupBound $ startupFun coscreen soptions++startupFun :: ScreenContent -> ClientOptions -> MVar RawFrontend -> IO ()+startupFun coscreen soptions@ClientOptions{..} rfMVar = do+ SDL.initialize [SDL.InitEvents]+ -- lowest: pattern SDL_LOG_PRIORITY_VERBOSE = (1) :: LogPriority+ -- our default: pattern SDL_LOG_PRIORITY_ERROR = (5) :: LogPriority+ SDL.logSetAllPriority $ toEnum $ fromMaybe 5 slogPriority+ TTF.initialize+ let title = T.pack $ fromJust stitle+     chosenFontsetID = fromJust schosenFontset+ -- Unlike @error@, @die@ does not move savefiles aside.+ chosenFontset <- case lookup chosenFontsetID sfontsets of+   Nothing -> die $ "Fontset not defined in config file"+                    `showFailure` chosenFontsetID+   Just fs -> return fs+     -- If some auxiliary fonts are equal and at the same size, this wastefully+     -- opens them many times. However, native builds are efficient enough+     -- and slow machines should use the most frugal case (only square font)+     -- in which no waste occurs and all rendering is aided with an atlas.+ let findFontFile t =+       if T.null t+       then return Nothing+       else case lookup t sfonts of+         Nothing -> die $ "Font not defined in config file" `showFailure` t+         Just (FontProportional fname fsize fhint) -> do+           sdlFont <- loadFontFile fname fsize+           setHintMode sdlFont fhint+           -- TODO: when SDL_ttf can do it, check that not a bitmap font+           realSize <- TTF.height sdlFont+           let !_A = assert (realSize > 0) ()  -- sanity+           return $ Just (sdlFont, realSize)+         Just (FontMonospace fname fsize fhint) -> do+           sdlFont <- loadFontFile fname fsize+           setHintMode sdlFont fhint+           isFontMono <- TTF.isMonospace sdlFont+           realSize <- TTF.height sdlFont+           let !_A = assert (isFontMono && realSize > 0) ()  -- sanity+           return $ Just (sdlFont, realSize)+         Just (FontMapScalable fname fsize fhint cellSizeAdd) -> do+           sdlFont <- loadFontFile fname fsize+           setHintMode sdlFont fhint+           isFontMono <- TTF.isMonospace sdlFont+           realSize <- TTF.height sdlFont+           let !_A = assert (isFontMono && realSize > 0) ()  -- sanity+           return $ Just (sdlFont, realSize + cellSizeAdd)+         Just (FontMapBitmap fname cellSizeAdd) -> do+           sdlFont <- loadFontFile fname 0  -- size ignored for bitmap fonts+           isFontMono <- TTF.isMonospace sdlFont+           realSize <- TTF.height sdlFont+           let !_A = assert (isFontMono && realSize > 0) ()  -- sanity+           return $ Just (sdlFont, realSize + cellSizeAdd)+     loadFontFile fname fsize = do+       let fontFileName = T.unpack fname+           fontSize = round $ fromJust sallFontsScale * intToDouble fsize+       if isRelative fontFileName+       then do+         case lookup fontFileName $ rFontFiles coscreen of+           Nothing -> fail $ "Font file not supplied with the game: "+                             ++ fontFileName+                             ++ " within "+                             ++ show (map fst $ rFontFiles coscreen)+           Just bs -> TTF.decode bs fontSize+       else do+         fontFileExists <- doesFileExist fontFileName+         if not fontFileExists+         then fail $ "Font file does not exist: " ++ fontFileName+         else TTF.load fontFileName fontSize+     setHintMode _ HintingHeavy = return ()  -- default+     setHintMode sdlFont HintingLight = TTF.setHinting sdlFont TTF.Light+ (squareFont, squareFontSize, mapFontIsBitmap) <-+   if fromJust sallFontsScale == 1.0 then do+     mfontMapBitmap <- findFontFile $ fontMapBitmap chosenFontset+     case mfontMapBitmap of+       Just (sdlFont, size) -> return (sdlFont, size, True)+       Nothing -> do+         mfontMapScalable <- findFontFile $ fontMapScalable chosenFontset+         case mfontMapScalable of+           Just (sdlFont, size) -> return (sdlFont, size, False)+           Nothing -> die "Neither bitmap nor scalable map font defined"+   else do+     mfontMapScalable <- findFontFile $ fontMapScalable chosenFontset+     case mfontMapScalable of+        Just (sdlFont, size) -> return (sdlFont, size, False)+        Nothing -> die "Scaling requested but scalable map font not defined"+ let halfSize = squareFontSize `div` 2+     boxSize = 2 * halfSize  -- map font determines cell size for all others+ -- Real size of these fonts ignored.+ spropFont <- fst <$$> findFontFile (fontPropRegular chosenFontset)+ sboldFont <- fst <$$> findFontFile (fontPropBold chosenFontset)+ smonoFont <- fst <$$> findFontFile (fontMono chosenFontset)+ let !_A =+       assert+         (isJust spropFont && isJust sboldFont && isJust smonoFont+          || isNothing spropFont && isNothing sboldFont && isNothing smonoFont+          `blame` "Either all auxiliary fonts should be defined or none"+          `swith` chosenFontset) ()+ -- The hacky log priority 0 tells SDL frontend to init and quit at once,+ -- for testing on CIs without graphics access.+ if slogPriority == Just 0 then do+  rf <- createRawFrontend coscreen (\_ -> return ()) (return ())+  putMVar rfMVar rf+  maybe (return ()) TTF.free spropFont+  maybe (return ()) TTF.free sboldFont+  maybe (return ()) TTF.free smonoFont+  TTF.free squareFont+  TTF.quit+  SDL.quit+ else do+  -- The code below fails without access to a graphics system.+  SDL.initialize [SDL.InitVideo]+  -- This cursor size if fine for default size and Full HD 1.5x size.+  let (cursorAlpha, cursorBW) = cursorXhair+  xhairCursor <-+    createCursor cursorBW cursorAlpha (SDL.V2 32 27) (SDL.P (SDL.V2 13 13))+  SDL.activeCursor SDL.$= xhairCursor+--  xhairCursor <-+--    throwIfNull "SDL.Input.Mouse.createSystemCursor" "SDL_createSystemCursor"+--    $ Raw.createSystemCursor Raw.SDL_SYSTEM_CURSOR_CROSSHAIR+--  SDL.activeCursor SDL.$= unsafeCoerce xhairCursor+  let screenV2 = SDL.V2 (toEnum $ rwidth coscreen * boxSize)+                        (toEnum $ rheight coscreen * boxSize)+      windowConfig = SDL.defaultWindow+        { SDL.windowInitialSize = screenV2+        , SDL.windowMode = case fromMaybe NotFullscreen sfullscreenMode of+            ModeChange -> SDL.Fullscreen+            BigBorderlessWindow -> SDL.FullscreenDesktop+            NotFullscreen -> SDL.Windowed+        , SDL.windowResizable = False  -- the default, but just in case...+        , SDL.windowHighDPI = True  -- possibly prevents resize for Retina+        }+      rendererConfig = SDL.RendererConfig+        { rendererType          = if sbenchmark+                                  then SDL.AcceleratedRenderer+                                  else SDL.AcceleratedVSyncRenderer+        , rendererTargetTexture = True+        }+  swindow <- SDL.createWindow title windowConfig+  srenderer <- SDL.createRenderer swindow (-1) rendererConfig+  unless (fromMaybe NotFullscreen sfullscreenMode == NotFullscreen) $+    -- This is essential to preserve game map aspect ratio in fullscreen, etc.,+    -- if the aspect ratios of video mode and game map view don't match.+    SDL.rendererLogicalSize srenderer SDL.$= Just screenV2+  let clearScreen = do+        -- Display black screen ASAP to hide any garbage. This is also needed+        -- to clear trash on the margins in fullscreen. No idea why the double+        -- calls are needed, sometimes. Perhaps it's double-buffered.+        SDL.rendererRenderTarget srenderer SDL.$= Nothing+        SDL.clear srenderer  -- clear the backbuffer+        SDL.present srenderer+        SDL.clear srenderer  -- clear the other half of the double buffer?+        SDL.present srenderer+  clearScreen+  let initTexture = do+        texture <- SDL.createTexture srenderer SDL.ARGB8888+                                     SDL.TextureAccessTarget screenV2+        SDL.rendererRenderTarget srenderer SDL.$= Just texture+        SDL.rendererDrawBlendMode srenderer SDL.$= SDL.BlendNone+        SDL.rendererDrawColor srenderer SDL.$= blackRGBA+        SDL.clear srenderer  -- clear the texture+        return texture+  basicTexture <- initTexture+  sbasicTexture <- newIORef basicTexture+  texture <- initTexture+  stexture <- newIORef texture+  squareAtlas <- newIORef EM.empty+  smonoAtlas <- newIORef EM.empty+  spreviousFrame <- newIORef $ blankSingleFrame coscreen+  sforcedShutdown <- newIORef False+  scontinueSdlLoop <- newIORef True+  sframeQueue <- newEmptyMVar+  sframeDrawn <- newEmptyMVar+  let sess = FrontendSession{..}+  rfWithoutPrintScreen <-+    createRawFrontend coscreen (display sess) (shutdown sess)+  let rf = rfWithoutPrintScreen {fprintScreen = printScreen sess}+  putMVar rfMVar rf+  let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> PointUI+      pointTranslate (SDL.P (SDL.V2 x y)) =+        PointUI (fromEnum x `div` halfSize) (fromEnum y `div` boxSize)+      redraw = do+        -- Textures may be trashed and even invalid, especially on Windows.+        atlas <- readIORef squareAtlas+        writeIORef squareAtlas EM.empty+        monoAtlas <- readIORef smonoAtlas+        writeIORef smonoAtlas EM.empty+        oldBasicTexture <- readIORef sbasicTexture+        newBasicTexture <- initTexture+        oldTexture <- readIORef stexture+        newTexture <- initTexture+        mapM_ SDL.destroyTexture $ EM.elems atlas+        mapM_ SDL.destroyTexture $ EM.elems monoAtlas+        SDL.destroyTexture oldBasicTexture+        SDL.destroyTexture oldTexture+        writeIORef sbasicTexture newBasicTexture+        writeIORef stexture newTexture+        -- To clear the margins in fullscreen:+        clearScreen+        -- To overwrite each char:+        prevFrame <- readIORef spreviousFrame+        writeIORef spreviousFrame $ blankSingleFrame coscreen+        drawFrame coscreen soptions sess prevFrame+        SDL.pumpEvents+        SDL.Raw.Event.flushEvents minBound maxBound+      loopSDL :: IO ()+      loopSDL = do+        me <- SDL.pollEvent  -- events take precedence over frames+        case me of+          Nothing -> do+            mfr <- tryTakeMVar sframeQueue+            case mfr of+              Just fr -> do+                -- Some SDL2 (OpenGL) backends are very thread-unsafe,+                -- so we need to ensure we draw on the same (bound) OS thread+                -- that initialized SDL, hence we have to poll frames.+                drawFrame coscreen soptions sess fr+                putMVar sframeDrawn ()  -- signal that drawing ended+              Nothing -> threadDelay $ if sbenchmark then 150 else 15000+                           -- 60 polls per second, so keyboard snappy enough;+                           -- max 6000 FPS when benchmarking+          Just e -> handleEvent e+        continueSdlLoop <- readIORef scontinueSdlLoop+        if continueSdlLoop+        then loopSDL+        else do+          maybe (return ()) TTF.free spropFont+          maybe (return ()) TTF.free sboldFont+          maybe (return ()) TTF.free smonoFont+          TTF.free squareFont+          TTF.quit+          SDL.destroyRenderer srenderer+          SDL.destroyWindow swindow+          SDL.quit+          forcedShutdown <- readIORef sforcedShutdown+          when forcedShutdown+            exitSuccess  -- not in the main thread, so no exit yet, see "Main"+      handleEvent e = case SDL.eventPayload e of+        SDL.KeyboardEvent keyboardEvent+          | SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed -> do+            let sym = SDL.keyboardEventKeysym keyboardEvent+                ksm = SDL.keysymModifier sym+                shiftPressed = SDL.keyModifierLeftShift ksm+                               || SDL.keyModifierRightShift ksm+                key = keyTranslate shiftPressed $ SDL.keysymKeycode sym+                modifier = modTranslate ksm+                modifierNoShift = case modifier of  -- to prevent S-!, etc.+                  K.Shift -> K.NoModifier+                  K.ControlShift -> K.Control+                  K.AltShift -> K.Alt+                  _ -> modifier+            p <- SDL.getAbsoluteMouseLocation+            when (key == K.Esc) $ resetChanKey (fchanKey rf)+            saveKMP rf modifierNoShift key (pointTranslate p)+        SDL.MouseButtonEvent mouseButtonEvent+          | SDL.mouseButtonEventMotion mouseButtonEvent == SDL.Released -> do+            modifier <- modTranslate <$> SDL.getModState+            let key = case SDL.mouseButtonEventButton mouseButtonEvent of+                  SDL.ButtonLeft -> K.LeftButtonRelease+                  SDL.ButtonMiddle -> K.MiddleButtonRelease+                  SDL.ButtonRight -> K.RightButtonRelease+                  _ -> K.LeftButtonRelease  -- any other is spare left+                p = SDL.mouseButtonEventPos mouseButtonEvent+            saveKMP rf modifier key (pointTranslate p)+        SDL.MouseWheelEvent mouseWheelEvent -> do+          modifier <- modTranslate <$> SDL.getModState+          let SDL.V2 _ y = SDL.mouseWheelEventPos mouseWheelEvent+              mkey = case (compare y 0, SDL.mouseWheelEventDirection+                                          mouseWheelEvent) of+                (EQ, _) -> Nothing+                (LT, SDL.ScrollNormal) -> Just K.WheelSouth+                (GT, SDL.ScrollNormal) -> Just K.WheelNorth+                (LT, SDL.ScrollFlipped) -> Just K.WheelNorth+                (GT, SDL.ScrollFlipped) -> Just K.WheelSouth+          p <- SDL.getAbsoluteMouseLocation+          maybe (return ())+                (\key -> saveKMP rf modifier key (pointTranslate p)) mkey+        SDL.WindowClosedEvent{} -> forceShutdown sess+        SDL.QuitEvent -> forceShutdown sess+        SDL.WindowRestoredEvent{} -> redraw  -- e.g., unminimize+        SDL.WindowExposedEvent{} -> redraw  -- needed on Windows+        SDL.WindowResizedEvent{} ->+          -- Some window managers apparently are able to resize.+          -- And some send resize events at startup, even though+          -- they don't resize eventually, so this is too much spam:+          -- SDL.showSimpleMessageBox Nothing SDL.Warning+          --  "Windows resize detected"+          --  "Please resize the game and/or make it fullscreen via 'allFontsScale' and 'fullscreenMode' settings in the 'config.ui.ini' file. Resizing fonts via generic scaling algorithms gives poor results."+          redraw+        -- Probably not needed, because no textures nor their content lost:+        -- SDL.WindowShownEvent{} -> redraw+        _ -> return ()+  loopSDL++-- | Copied from SDL2 and fixed (packed booleans are needed).+--+-- Create a cursor using the specified bitmap data and mask (in MSB format,+-- packed). Width must be a multiple of 8.+--+--+createCursor :: MonadIO m+             => VS.Vector Word8 -- ^ Whether this part of the cursor is black. Use bit 1 for white and bit 0 for black.+             -> VS.Vector Word8 -- ^ Whether or not pixels are visible. Use bit 1 for visible and bit 0 for transparent.+             -> Vect.V2 CInt -- ^ The width and height of the cursor.+             -> Vect.Point Vect.V2 CInt -- ^ The X- and Y-axis location of the upper left corner of the cursor relative to the actual mouse position+             -> m SDL.Cursor+createCursor dta msk (Vect.V2 w h) (Vect.P (Vect.V2 hx hy)) =+    liftIO . fmap unsafeCoerce $+        throwIfNull "SDL.Input.Mouse.createCursor" "SDL_createCursor" $+            VS.unsafeWith dta $ \unsafeDta ->+            VS.unsafeWith msk $ \unsafeMsk ->+                Raw.createCursor unsafeDta unsafeMsk w h hx hy++-- Ignores bits after the last 8 multiple.+boolListToWord8List :: [Bool] -> [Word8]+boolListToWord8List =+  let i True multiple = multiple+      i False _ = 0+  in \case+    b1 : b2 : b3 : b4 : b5 : b6 : b7 : b8 : rest ->+      i b1 128 + i b2 64 + i b3 32 + i b4 16 + i b5 8 + i b6 4 + i b7 2 + i b8 1+      : boolListToWord8List rest+    _ -> []++cursorXhair :: (VS.Vector Word8, VS.Vector Word8)  -- alpha, BW+cursorXhair =+  let charToBool '.' = (True, True)  -- visible black+      charToBool '#' = (True, False)  -- visible white+      charToBool _ = (False, False)  -- transparent white+      toVS = VS.fromList . boolListToWord8List+  in toVS *** toVS $ unzip $ map charToBool $ concat++    [ "            ...                 "+    , "            .#.                 "+    , "        ..  .#.  ..             "+    , "      ..##  .#.  ##..           "+    , "     .##    .#.    ##.          "+    , "    .#      .#.      #.         "+    , "   .#       .#.       #.        "+    , "   .#       ...       #.        "+    , "  .#                   #.       "+    , "  .#                   #.       "+    , "                                "+    , "             .                  "+    , "........    .#.    ........     "+    , ".######.   .###.   .######.     "+    , "........    .#.    ........     "+    , "             .                  "+    , "                                "+    , "  .#                   #.       "+    , "  .#                   #.       "+    , "   .#       ...       #.        "+    , "   .#       .#.       #.        "+    , "    .#      .#.      #.         "+    , "     .##    .#.    ##.          "+    , "      ..##  .#.  ##..           "+    , "        ..  .#.  ..             "+    , "            .#.                 "+    , "            ...                 " ]++shutdown :: FrontendSession -> IO ()+shutdown FrontendSession{..} = writeIORef scontinueSdlLoop False++forceShutdown :: FrontendSession -> IO ()+forceShutdown sess@FrontendSession{..} = do+  writeIORef sforcedShutdown True+  shutdown sess++-- | Add a frame to be drawn.+display :: FrontendSession  -- ^ frontend session data+        -> SingleFrame      -- ^ the screen frame to draw+        -> IO ()+display FrontendSession{..} curFrame = do+  continueSdlLoop <- readIORef scontinueSdlLoop+  if continueSdlLoop then do+    putMVar sframeQueue curFrame+    -- Wait until the frame is drawn.+    takeMVar sframeDrawn+  else do+    forcedShutdown <- readIORef sforcedShutdown+    when forcedShutdown $+      -- When there's a forced shutdown, ignore displaying one frame+      -- and don't occupy the CPU creating new ones and moving on with the game+      -- (possibly also saving the new game state, surprising the player),+      -- but delay the server and client thread(s) for a long time+      -- and let the SDL-init thread clean up and exit via @exitSuccess@+      -- to avoid exiting via "thread blocked".+      threadDelay 50000++drawFrame :: ScreenContent    -- ^ e.g., game screen size+          -> ClientOptions    -- ^ client options+          -> FrontendSession  -- ^ frontend session data+          -> SingleFrame      -- ^ the screen frame to draw+          -> IO ()+drawFrame coscreen ClientOptions{..} sess@FrontendSession{..} curFrame = do+  prevFrame <- readIORef spreviousFrame+  let halfSize = squareFontSize `div` 2+      boxSize = 2 * halfSize+      tt2Square = Vect.V2 (toEnum boxSize) (toEnum boxSize)+      vp :: Int -> Int -> Vect.Point Vect.V2 CInt+      vp x y = Vect.P $ Vect.V2 (toEnum x) (toEnum y)+      drawHighlight !col !row !color = do+        SDL.rendererDrawColor srenderer SDL.$= colorToRGBA color+        let rect = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square+        SDL.drawRect srenderer $ Just rect+        SDL.rendererDrawColor srenderer SDL.$= blackRGBA+          -- reset back to black+      chooseAndDrawHighlight !col !row !bg = do+-- Rectangle drawing is broken in SDL 2.0.16+-- (https://github.com/LambdaHack/LambdaHack/issues/281)+-- and simple workarounds fail with old SDL, e.g., four lines instead of+-- a rectangle, so we have to manually erase the broken rectangles+-- instead of depending on glyphs overwriting them fully.+       let workaroundOverwriteHighlight = do+             let rect = SDL.Rectangle (vp (col * boxSize) (row * boxSize))+                                      tt2Square+             SDL.drawRect srenderer $ Just rect+       case bg of+        Color.HighlightNone -> workaroundOverwriteHighlight+        Color.HighlightBackground -> workaroundOverwriteHighlight+        Color.HighlightNoneCursor -> workaroundOverwriteHighlight+        _ -> drawHighlight col row $ Color.highlightToColor bg+-- workarounds end+      -- This also frees the surface it gets.+      scaleSurfaceToTexture :: Int -> SDL.Surface -> IO SDL.Texture+      scaleSurfaceToTexture xsize textSurfaceRaw = do+        Vect.V2 sw sh <- SDL.surfaceDimensions textSurfaceRaw+        let width = min xsize $ fromEnum sw+            height = min boxSize $ fromEnum sh+            xsrc = max 0 (fromEnum sw - width) `div` 2+            ysrc = max 0 (fromEnum sh - height) `divUp` 2+            srcR = SDL.Rectangle (vp xsrc ysrc)+                                 (Vect.V2 (toEnum width) (toEnum height))+            xtgt = (xsize - width) `divUp` 2+            ytgt = (boxSize - height) `div` 2+            tgtR = vp xtgt ytgt+            tt2 = Vect.V2 (toEnum xsize) (toEnum boxSize)+        textSurface <- SDL.createRGBSurface tt2 SDL.ARGB8888+        SDL.surfaceFillRect textSurface Nothing blackRGBA+        -- We crop surface rather than texture to set the resulting+        -- texture as @TextureAccessStatic@ via @createTextureFromSurface@,+        -- which otherwise we wouldn't be able to do.+        void $ SDL.surfaceBlit textSurfaceRaw (Just srcR)+                               textSurface (Just tgtR)+        SDL.freeSurface textSurfaceRaw+        textTexture <- SDL.createTextureFromSurface srenderer textSurface+        SDL.freeSurface textSurface+        return textTexture+      -- This also frees the surface it gets.+      scaleSurfaceToTextureProp :: Int -> Int -> SDL.Surface -> Bool+                                -> IO (Int, SDL.Texture)+      scaleSurfaceToTextureProp x row textSurfaceRaw allSpace = do+        Vect.V2 sw sh <- SDL.surfaceDimensions textSurfaceRaw+        let widthRaw = fromEnum sw+            remainingWidth = rwidth coscreen * boxSize - x+            width | widthRaw <= remainingWidth = widthRaw+                  | allSpace = remainingWidth+                  | otherwise = remainingWidth - boxSize+            height = min boxSize $ fromEnum sh+            xsrc = 0+            ysrc = max 0 (fromEnum sh - height) `divUp` 2+            srcR = SDL.Rectangle (vp xsrc ysrc)+                                 (Vect.V2 (toEnum width) (toEnum height))+            xtgt = 0+            ytgt = (boxSize - height) `div` 2+            tgtR = vp xtgt ytgt+            tt2Prop = Vect.V2 (toEnum width) (toEnum boxSize)+        textSurface <- SDL.createRGBSurface tt2Prop SDL.ARGB8888+        SDL.surfaceFillRect textSurface Nothing blackRGBA+        -- We crop surface rather than texture to set the resulting+        -- texture as @TextureAccessStatic@ via @createTextureFromSurface@,+        -- which otherwise we wouldn't be able to do.+        -- This is not essential for proportional font, for which we have+        -- no texture atlas, but it's consistent with other fonts+        -- and the bottleneck is the square font, anyway.+        void $ SDL.surfaceBlit textSurfaceRaw (Just srcR)+                               textSurface (Just tgtR)+        SDL.freeSurface textSurfaceRaw+        textTexture <- SDL.createTextureFromSurface srenderer textSurface+        SDL.freeSurface textSurface+        when (width /= widthRaw && not allSpace) $+          setSquareChar (rwidth coscreen - 1) row Color.trimmedLineAttrW32+        return (width, textTexture)+      -- <https://www.libsdl.org/projects/SDL_ttf/docs/SDL_ttf_42.html#SEC42>+      -- Note that @Point@ here refers to screen coordinates with square font+      -- (as @PointSquare@ normally should) and not game map coordinates.+      -- See "Game.LambdaHack.Client.UI.Frame" for explanation of this+      -- irregularity.+      setMapChar :: PointI -> (Word32, Word32) -> IO Int+      setMapChar !i (!w, !wPrev) =+        if w == wPrev+        then return $! i + 1+        else do+          let Point{..} = toEnum i+          setSquareChar px py (Color.AttrCharW32 w)+          return $! i + 1+      drawMonoOverlay :: OverlaySpace -> IO ()+      drawMonoOverlay =+        mapM_ (\(PointUI x y, al) ->+                 let lineCut = take (2 * rwidth coscreen - x) al+                 in drawMonoLine x y lineCut)+      drawMonoLine :: Int -> Int -> AttrString -> IO ()+      drawMonoLine _ _ [] = return ()+      drawMonoLine x row (w : rest) = do+        setMonoChar x row w+        drawMonoLine (x + 1) row rest+      setMonoChar :: Int -> Int -> Color.AttrCharW32 -> IO ()+      setMonoChar !x !row !w = do+        atlas <- readIORef smonoAtlas+        let Color.AttrChar{acAttr=Color.Attr{fg=fgRaw, bg}, acChar} =+              Color.attrCharFromW32 w+            fg | even row && fgRaw == Color.White = Color.AltWhite+               | otherwise = fgRaw+            ac = Color.attrChar2ToW32 fg acChar+            !_A = assert (bg `elem` [ Color.HighlightNone+                                    , Color.HighlightNoneCursor ]) ()+        textTexture <- case EM.lookup ac atlas of+          Nothing -> do+            textSurfaceRaw <-+              TTF.shadedGlyph (fromJust smonoFont) (colorToRGBA fg)+                              blackRGBA acChar+            textTexture <- scaleSurfaceToTexture halfSize textSurfaceRaw+            writeIORef smonoAtlas $ EM.insert ac textTexture atlas+            return textTexture+          Just textTexture -> return textTexture+        let tt2Mono = Vect.V2 (toEnum halfSize) (toEnum boxSize)+            tgtR = SDL.Rectangle (vp (x * halfSize) (row * boxSize)) tt2Mono+        SDL.copy srenderer textTexture Nothing (Just tgtR)+      drawSquareOverlay :: OverlaySpace -> IO ()+      drawSquareOverlay =+        mapM_ (\(pUI, al) ->+                 let PointSquare col row = uiToSquare pUI+                     lineCut = take (rwidth coscreen - col) al+                 in drawSquareLine col row lineCut)+      drawSquareLine :: Int -> Int -> AttrString -> IO ()+      drawSquareLine _ _ [] = return ()+      drawSquareLine col row (w : rest) = do+        setSquareChar col row w+        drawSquareLine (col + 1) row rest+      setSquareChar :: Int -> Int -> Color.AttrCharW32 -> IO ()+      setSquareChar !col !row !w = do+        atlas <- readIORef squareAtlas+        let Color.AttrChar{ acAttr=Color.Attr{fg=fgRaw, bg}+                          , acChar=acCharRaw } =+              Color.attrCharFromW32 w+            fg | even row && fgRaw == Color.White = Color.AltWhite+               | otherwise = fgRaw+            ac = if bg == Color.HighlightBackground+                 then w+                 else Color.attrChar2ToW32 fg acCharRaw+        textTexture <- case EM.lookup ac atlas of+          Nothing -> do+            -- Make all visible floors bold (no bold font variant for 16x16x,+            -- so only the dot can be bold).+            let acChar = if not (Color.isBright fg)+                            && acCharRaw == floorSymbol  -- '\x00B7'+                         then if mapFontIsBitmap+                              then '\x0007'+                              else '\x22C5'+                         else acCharRaw+                background = if bg == Color.HighlightBackground+                             then greyRGBA+                             else blackRGBA+            textSurfaceRaw <- TTF.shadedGlyph squareFont (colorToRGBA fg)+                                              background acChar+            textTexture <- scaleSurfaceToTexture boxSize textSurfaceRaw+            writeIORef squareAtlas $ EM.insert ac textTexture atlas+            return textTexture+          Just textTexture -> return textTexture+        let tgtR = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square+        SDL.copy srenderer textTexture Nothing (Just tgtR)+        -- Potentially overwrite a portion of the glyph.+        chooseAndDrawHighlight col row bg+      drawPropOverlay :: OverlaySpace -> IO ()+      drawPropOverlay =+        mapM_ (\(PointUI x y, al) ->+                 drawPropLine (x * halfSize) y al)+      drawPropLine :: Int -> Int -> AttrString -> IO ()+      drawPropLine _ _ [] = return ()+      drawPropLine x _ _ | x >= (rwidth coscreen - 1) * boxSize =+        -- This chunk starts at $ sign or beyond so, for KISS, reject it.+        return ()+      drawPropLine x row (w : rest) = do+        let isSpace = (== Color.spaceAttrW32)+            Color.AttrChar{acAttr=Color.Attr{fg=fgRaw, bg}} =+              Color.attrCharFromW32+              $ if isSpace w+                then case filter (not . isSpace) rest of+                  w2 : _ -> w2+                  [] -> w+                else w+            sameAttr ac = Color.fgFromW32 ac == fgRaw+                          || isSpace ac  -- matches all colours+            (sameRest, otherRest) = span sameAttr rest+            !_A = assert (bg `elem` [ Color.HighlightNone+                                    , Color.HighlightNoneCursor ]) ()+            fg | even row && fgRaw == Color.White = Color.AltWhite+               | otherwise = fgRaw+            t = T.pack . attrStringToString  $ w : sameRest+        width <- drawPropChunk x row fg t+        drawPropLine (x + width) row otherRest+      drawPropChunk :: Int -> Int -> Color.Color -> T.Text -> IO Int+      drawPropChunk x row fg t = do+        let font = if fg >= Color.White && fg /= Color.BrBlack+                   then spropFont+                   else sboldFont+            allSpace = T.all Char.isSpace t+        textSurfaceRaw <- TTF.shaded (fromJust font) (colorToRGBA fg)+                                     blackRGBA t+        (width, textTexture) <-+          scaleSurfaceToTextureProp x row textSurfaceRaw allSpace+        let tgtR = SDL.Rectangle (vp x (row * boxSize))+                                 (Vect.V2 (toEnum width) (toEnum boxSize))+        -- Potentially overwrite some of the screen.+        SDL.copy srenderer textTexture Nothing (Just tgtR)+        SDL.destroyTexture textTexture+        return width+  let arraysEqual = singleArray curFrame == singleArray prevFrame+      overlaysEqual =+        singleMonoOverlay curFrame == singleMonoOverlay prevFrame+        && singleSquareOverlay curFrame == singleSquareOverlay prevFrame+        && singlePropOverlay curFrame == singlePropOverlay prevFrame+  basicTexture <- readIORef sbasicTexture  -- previous content still present+  unless arraysEqual $ do+    SDL.rendererRenderTarget srenderer SDL.$= Just basicTexture+    U.foldM'_ setMapChar 0 $ U.zip (PointArray.avector $ singleArray curFrame)+                                   (PointArray.avector $ singleArray prevFrame)+  unless (arraysEqual && overlaysEqual) $ do+    texture <- readIORef stexture+    SDL.rendererRenderTarget srenderer SDL.$= Just texture+    SDL.copy srenderer basicTexture Nothing Nothing  -- overwrite last content+    -- Mono overlay rendered last, because more likely to come after+    -- the proportional one and so to have a warning message about overrun+    -- that needs to be overlaid on top of the proportional overlay.+    drawPropOverlay $ singlePropOverlay curFrame+    drawSquareOverlay $ singleSquareOverlay curFrame+    drawMonoOverlay $ singleMonoOverlay curFrame+    writeIORef spreviousFrame curFrame+    SDL.rendererRenderTarget srenderer SDL.$= Nothing+    SDL.copy srenderer texture Nothing Nothing  -- overwrite the backbuffer+    SDL.present srenderer+    -- We can't print screen in @display@ due to thread-unsafety.+    when sprintEachScreen $ printScreen sess++-- It can't seem to cope with SDL_PIXELFORMAT_INDEX8, so we are stuck+-- with huge bitmaps.+printScreen :: FrontendSession -> IO ()+printScreen FrontendSession{..} = do+  dataDir <- appDataDir+  tryCreateDir dataDir+  tryCreateDir $ dataDir </> "screenshots"+  utcTime <- getCurrentTime+  timezone <- getTimeZone utcTime+  let unspace = map $ \c -> case c of  -- prevent the need for backquoting+        ' ' -> '_'+        ':' -> '.'+        _ -> c+      dateText = unspace $ take 25 $ show $ utcToLocalTime timezone utcTime+      fileName = dataDir </> "screenshots" </> "prtscn" <> dateText <.> "bmp"+      SDL.Internal.Types.Renderer renderer = srenderer+  Vect.V2 sw sh <- SDL.get $ SDL.windowSize swindow+  ptrOut <- SDL.Raw.Video.createRGBSurface 0 sw sh 32 0 0 0 0+  surfaceOut <- peek ptrOut+  void $ SDL.Raw.Video.renderReadPixels+    renderer+    nullPtr+    SDL.Raw.Enum.SDL_PIXELFORMAT_ARGB8888+    (SDL.Raw.Types.surfacePixels surfaceOut)+    (sw * 4)+  withCString fileName $ \fileNameCString ->+    void $! SDL.Raw.Video.saveBMP ptrOut fileNameCString+  SDL.Raw.Video.freeSurface ptrOut++-- | Translates modifiers to our own encoding.+modTranslate :: SDL.KeyModifier -> K.Modifier+modTranslate m =+  modifierTranslate+    (SDL.keyModifierLeftCtrl m || SDL.keyModifierRightCtrl m)+    (SDL.keyModifierLeftShift m || SDL.keyModifierRightShift m)+    (SDL.keyModifierLeftAlt m+     || SDL.keyModifierRightAlt m+     || SDL.keyModifierAltGr m+     || SDL.keyModifierLeftGUI m+     || SDL.keyModifierRightGUI m)+    False++keyTranslate :: Bool -> SDL.Keycode -> K.Key+keyTranslate shiftPressed n = case n of+  KeycodeEscape     -> K.Esc+  KeycodeReturn     -> K.Return+  KeycodeBackspace  -> K.BackSpace+  KeycodeTab        -> if shiftPressed then K.BackTab else K.Tab+  KeycodeSpace      -> K.Space+  KeycodeExclaim -> K.Char '!'+  KeycodeQuoteDbl -> K.Char '"'+  KeycodeHash -> K.Char '#'+  KeycodePercent -> K.Char '%'+  KeycodeDollar -> K.Char '$'+  KeycodeAmpersand -> K.Char '&'+  KeycodeQuote -> if shiftPressed then K.Char '"' else K.Char '\''+  KeycodeLeftParen -> K.Char '('+  KeycodeRightParen -> K.Char ')'+  KeycodeAsterisk -> K.Char '*'+  KeycodePlus -> K.Char '+'+  KeycodeComma -> if shiftPressed then K.Char '<' else K.Char ','+  KeycodeMinus -> if shiftPressed then K.Char '_' else K.Char '-'+  KeycodePeriod -> if shiftPressed then K.Char '>' else K.Char '.'+  KeycodeSlash -> if shiftPressed then K.Char '?' else K.Char '/'+  Keycode1 -> if shiftPressed then K.Char '!' else K.Char '1'+  Keycode2 -> if shiftPressed then K.Char '@' else K.Char '2'+  Keycode3 -> if shiftPressed then K.Char '#' else K.Char '3'+  Keycode4 -> if shiftPressed then K.Char '$' else K.Char '4'+  Keycode5 -> if shiftPressed then K.Char '%' else K.Char '5'+  Keycode6 -> if shiftPressed then K.Char '^' else K.Char '6'+  Keycode7 -> if shiftPressed then K.Char '&' else K.Char '7'+  Keycode8 -> if shiftPressed then K.Char '*' else K.Char '8'+  Keycode9 -> if shiftPressed then K.Char '(' else K.Char '9'+  Keycode0 -> if shiftPressed then K.Char ')' else K.Char '0'+  KeycodeColon -> K.Char ':'+  KeycodeSemicolon -> if shiftPressed then K.Char ':' else K.Char ';'+  KeycodeLess -> K.Char '<'+  KeycodeEquals -> if shiftPressed then K.Char '+' else K.Char '='+  KeycodeGreater -> K.Char '>'+  KeycodeQuestion -> K.Char '?'+  KeycodeAt -> K.Char '@'+  KeycodeLeftBracket -> if shiftPressed then K.Char '{' else K.Char '['+  KeycodeBackslash -> if shiftPressed then K.Char '|' else K.Char '\\'+  KeycodeRightBracket -> if shiftPressed then K.Char '}' else K.Char ']'+  KeycodeCaret -> K.Char '^'+  KeycodeUnderscore -> K.Char '_'+  KeycodeBackquote -> if shiftPressed then K.Char '~' else K.Char '`'+  Keycode 167      -> if shiftPressed then K.Char '~' else K.Char '`'+    -- on some keyboards the key below ESC is paragraph and its scancode is 167+    -- and moreover SDL sometimes gives this code even on normal keyboards+  KeycodeUp         -> K.Up+  KeycodeDown       -> K.Down+  KeycodeLeft       -> K.Left+  KeycodeRight      -> K.Right+  KeycodeHome       -> K.Home+  KeycodeEnd        -> K.End+  KeycodePageUp     -> K.PgUp+  KeycodePageDown   -> K.PgDn+  KeycodeInsert     -> K.Insert+  KeycodeDelete     -> K.Delete+  KeycodePrintScreen -> K.PrintScreen+  KeycodeClear -> K.Begin+  KeycodeKPClear -> K.Begin+  KeycodeKPDivide   -> if shiftPressed then K.Char '?' else K.Char '/'+                         -- KP and normal are merged here+  KeycodeKPMultiply -> K.Char '*'  -- KP and normal are merged here+  KeycodeKPMinus    -> K.Char '-'  -- KP and normal are merged here+  KeycodeKPPlus     -> K.Char '+'  -- KP and normal are merged here+  KeycodeKPEnter    -> K.Return+  KeycodeKPEquals   -> K.Return  -- in case of some funny layouts+  KeycodeKP1 -> if shiftPressed then K.KP '1' else K.End+  KeycodeKP2 -> if shiftPressed then K.KP '2' else K.Down+  KeycodeKP3 -> if shiftPressed then K.KP '3' else K.PgDn+  KeycodeKP4 -> if shiftPressed then K.KP '4' else K.Left+  KeycodeKP5 -> if shiftPressed then K.KP '5' else K.Begin+  KeycodeKP6 -> if shiftPressed then K.KP '6' else K.Right+  KeycodeKP7 -> if shiftPressed then K.KP '7' else K.Home+  KeycodeKP8 -> if shiftPressed then K.KP '8' else K.Up+  KeycodeKP9 -> if shiftPressed then K.KP '9' else K.PgUp+  KeycodeKP0 -> if shiftPressed then K.KP '0' else K.Insert+  KeycodeKPPeriod -> K.Char '.'  -- dot and comma are merged here+  KeycodeKPComma  -> K.Char '.'  -- to sidestep national standards+  KeycodeF1       -> K.Fun 1+  KeycodeF2       -> K.Fun 2+  KeycodeF3       -> K.Fun 3+  KeycodeF4       -> K.Fun 4+  KeycodeF5       -> K.Fun 5+  KeycodeF6       -> K.Fun 6+  KeycodeF7       -> K.Fun 7+  KeycodeF8       -> K.Fun 8+  KeycodeF9       -> K.Fun 9+  KeycodeF10      -> K.Fun 10+  KeycodeF11      -> K.Fun 11+  KeycodeF12      -> K.Fun 12+  KeycodeLCtrl    -> K.DeadKey+  KeycodeLShift   -> K.DeadKey+  KeycodeLAlt     -> K.DeadKey+  KeycodeLGUI     -> K.DeadKey+  KeycodeRCtrl    -> K.DeadKey+  KeycodeRShift   -> K.DeadKey+  KeycodeRAlt     -> K.DeadKey+  KeycodeRGUI     -> K.DeadKey+  KeycodeMode     -> K.DeadKey+  KeycodeNumLockClear -> K.DeadKey+  KeycodeUnknown  -> K.Unknown "KeycodeUnknown"+  _ -> let i = fromEnum $ unwrapKeycode n+       in if | 97 <= i && i <= 122+               && shiftPressed -> K.Char $ Char.chr $ i - 32+             | 32 <= i && i <= 126 -> K.Char $ Char.chr i+             | otherwise -> K.Unknown $ show n+++sDL_ALPHA_OPAQUE :: Word8+sDL_ALPHA_OPAQUE = 255++blackRGBA :: SDL.V4 Word8+blackRGBA = SDL.V4 0 0 0 sDL_ALPHA_OPAQUE++-- A third of @colorToRGBA Color.BrBlack@ to compensate for the use+-- as background (high area) as opposed to glyphs (usually small area).+greyRGBA :: SDL.V4 Word8+greyRGBA = SDL.V4 0x25 0x1F 0x1F sDL_ALPHA_OPAQUE++-- This code is sadly duplicated from "Game.LambdaHack.Definition.Color".+colorToRGBA :: Color.Color -> SDL.V4 Word8+colorToRGBA Color.Black     = blackRGBA+colorToRGBA Color.Red       = SDL.V4 0xD5 0x05 0x05 sDL_ALPHA_OPAQUE+colorToRGBA Color.Green     = SDL.V4 0x05 0x9D 0x05 sDL_ALPHA_OPAQUE+colorToRGBA Color.Brown     = SDL.V4 0xCA 0x4A 0x05 sDL_ALPHA_OPAQUE+colorToRGBA Color.Blue      = SDL.V4 0x05 0x56 0xF4 sDL_ALPHA_OPAQUE+colorToRGBA Color.Magenta   = SDL.V4 0xAF 0x0E 0xAF sDL_ALPHA_OPAQUE+colorToRGBA Color.Cyan      = SDL.V4 0x05 0x96 0x96 sDL_ALPHA_OPAQUE+colorToRGBA Color.White     = SDL.V4 0xB8 0xBF 0xCB sDL_ALPHA_OPAQUE+colorToRGBA Color.AltWhite  = SDL.V4 0xC4 0xBE 0xB1 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrBlack   = SDL.V4 0x6F 0x5F 0x5F sDL_ALPHA_OPAQUE+colorToRGBA Color.BrRed     = SDL.V4 0xFF 0x55 0x55 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrGreen   = SDL.V4 0x65 0xF1 0x36 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrYellow  = SDL.V4 0xEB 0xD6 0x42 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrBlue    = SDL.V4 0x4D 0x98 0xF4 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrMagenta = SDL.V4 0xFF 0x77 0xFF sDL_ALPHA_OPAQUE+colorToRGBA Color.BrCyan    = SDL.V4 0x52 0xF4 0xE5 sDL_ALPHA_OPAQUE+colorToRGBA Color.BrWhite   = SDL.V4 0xFF 0xFF 0xFF sDL_ALPHA_OPAQUE
+ engine-src/Game/LambdaHack/Client/UI/Frontend/Teletype.hs view
@@ -0,0 +1,81 @@+-- | Line terminal text frontend based on stdin/stdout, intended for logging+-- tests, but may be used on a teletype terminal, or with keyboard and printer.+module Game.LambdaHack.Client.UI.Frontend.Teletype+  ( startup, frontendName+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent.Async+import           Data.Char (chr, ord)+import qualified System.IO as SIO++import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.Frontend.Common+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.PointUI+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Content.TileKind (floorSymbol)+import qualified Game.LambdaHack.Definition.Color as Color++-- No session data maintained by this frontend++-- | The name of the frontend.+frontendName :: String+frontendName = "teletype"++-- | Set up the frontend input and output.+startup :: ScreenContent -> IO RawFrontend+startup coscreen = do+  rf <- createRawFrontend coscreen (display coscreen) shutdown+  let storeKeys :: IO ()+      storeKeys = do+        c <- SIO.getChar  -- blocks here, so no polling+        SIO.hPutStrLn SIO.stderr ""  -- prevent next line starting indented+        let K.KM{..} = keyTranslate c+        saveKMP rf modifier key (PointUI 0 0)+        storeKeys+  SIO.hSetBuffering SIO.stdin SIO.NoBuffering+  SIO.hSetBuffering SIO.stderr $ SIO.BlockBuffering $+    Just $ 2 * rwidth coscreen * rheight coscreen+  void $ async storeKeys+  return $! rf++shutdown :: IO ()+shutdown = SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr++-- | Output to the screen via the frontend.+display :: ScreenContent+        -> SingleFrame+        -> IO ()+display coscreen SingleFrame{singleArray} = do+  let f w l =+        let acCharRaw = Color.charFromW32 w+            acChar = if acCharRaw == floorSymbol then '.' else acCharRaw+        in acChar : l+      levelChar = chunk $ PointArray.foldrA f [] singleArray+      chunk [] = []+      chunk l = let (ch, r) = splitAt (rwidth coscreen) l+                in ch : chunk r+  SIO.hPutStr SIO.stderr $ unlines levelChar+  SIO.hFlush SIO.stderr++keyTranslate :: Char -> K.KM+keyTranslate e = (\(key, modifier) -> K.KM modifier key) $+  case e of+    '\ESC' -> (K.Esc,     K.NoModifier)+    '\n'   -> (K.Return,  K.NoModifier)+    '\r'   -> (K.Return,  K.NoModifier)+    ' '    -> (K.Space,   K.NoModifier)+    '\t'   -> (K.Tab,     K.NoModifier)+    c | ord '\^A' <= ord c && ord c <= ord '\^Z' ->+        -- Alas, only lower-case letters.+        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)+        -- Movement keys are more important than leader picking,+        -- so disabling the latter and interpreting the keypad numbers+        -- as movement:+      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)+      | otherwise           -> (K.Char c,            K.NoModifier)
+ engine-src/Game/LambdaHack/Client/UI/HandleHelperM.hs view
@@ -0,0 +1,1109 @@+-- | Helper functions for both inventory management and human commands.+module Game.LambdaHack.Client.UI.HandleHelperM+  ( FailError, showFailError, MError, mergeMError, FailOrCmd, failWith+  , failSer, failMsg, weaveJust+  , pointmanCycle, pointmanCycleLevel, partyAfterLeader+  , pickLeader, doLook, pickLeaderWithPointer+  , itemOverlay, skillsOverlay, placesFromState, placesOverlay+  , factionsFromState, factionsOverlay+  , describeMode, modesOverlay+  , pickNumber, guardItemSize, lookAtItems, lookAtStash, lookAtPosition+  , displayOneMenuItem, okxItemLoreInline, okxItemLoreMsg, itemDescOverlays+  , cycleLore, spoilsBlurb, ppContainerWownW, nxtGameMode+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , itemOverlayFromState, lookAtTile, lookAtActors, guardItemVerbs+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Applicative+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.ItemDescription+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.HighScore as HighScore+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.FactionKind as FK+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.ModeKind as MK+import qualified Game.LambdaHack.Content.PlaceKind as PK+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs++-- | Message describing the cause of failure of human command.+newtype FailError = FailError {failError :: Text}+  deriving (Show, Eq)++showFailError :: FailError -> Text+showFailError (FailError err) = "*" <> err <> "*"++type MError = Maybe FailError++mergeMError :: MError -> MError -> MError+mergeMError Nothing Nothing = Nothing+mergeMError merr1@Just{} Nothing = merr1+mergeMError Nothing merr2@Just{} = merr2+mergeMError (Just err1) (Just err2) =+  Just $ FailError $ failError err1 <+> "and" <+> failError err2++type FailOrCmd a = Either FailError a++failWith :: MonadClientUI m => Text -> m (FailOrCmd a)+failWith err = assert (not $ T.null err) $ return $ Left $ FailError err++failSer :: MonadClientUI m => ReqFailure -> m (FailOrCmd a)+failSer = failWith . showReqFailure++failMsg :: MonadClientUI m => Text -> m MError+failMsg err = assert (not $ T.null err) $ return $ Just $ FailError err++weaveJust :: FailOrCmd a -> Either MError a+weaveJust (Left ferr) = Left $ Just ferr+weaveJust (Right a) = Right a++-- | Switches current pointman to the next on the level, if any, wrapping.+pointmanCycleLevel :: MonadClientUI m+                   => ActorId -> Bool -> Direction -> m MError+pointmanCycleLevel leader verbose direction = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  lidV <- viewedLevelUI+  body <- getsState $ getActorBody leader+  hs <- partyAfterLeader leader+  let banned = bannedPointmanSwitchBetweenLevels fact+      hsSort = case direction of+        Forward -> hs+        Backward -> reverse hs+  case filter (\(_, b, _) -> blid b == lidV) hsSort of+    _ | banned && lidV /= blid body ->+      failMsg $ showReqFailure NoChangeDunLeader+    [] -> failMsg "cannot pick any other pointman on this level"+    (np, _b, _) : _ -> do+      _success <- pickLeader verbose np+-- This apparently crashes rarely, probably becuase @leader@ gets out of sync+-- with the leader in client state, during nested UI manipulations.+-- The worst that can happen is TAB doing nothing and having to be repeated+-- or perhaps item manipulation needs to be exited for TAB to work again.+--      let !_A = assert (success `blame` "same leader"+--                                `swith` (leader, np, b)) ()+      return Nothing++-- | Switches current pointman to the previous in the whole dungeon, wrapping.+pointmanCycle :: MonadClientUI m+              => ActorId -> Bool -> Direction -> m MError+pointmanCycle leader verbose direction = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  hs <- partyAfterLeader leader+  let banned = bannedPointmanSwitchBetweenLevels fact+      hsSort = case direction of+        Forward -> hs+        Backward -> reverse hs+  case hsSort of+    _ | banned -> failMsg $ showReqFailure NoChangeDunLeader+    [] -> failMsg "no other member in the party"+    (np, b, _) : _ -> do+      success <- pickLeader verbose np+      let !_A = assert (success `blame` "same leader"+                                `swith` (leader, np, b)) ()+      return Nothing++partyAfterLeader :: MonadClientUI m => ActorId -> m [(ActorId, Actor, ActorUI)]+partyAfterLeader leader = do+  side <- getsClient sside+  sactorUI <- getsSession sactorUI+  allOurs <- getsState $ fidActorNotProjGlobalAssocs side -- not only on level+  let allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs+      hs = sortOn keySelected allOursUI+      i = fromMaybe (-1) $ findIndex (\(aid, _, _) -> aid == leader) hs+      (lt, gt) = (take i hs, drop (i + 1) hs)+  return $! gt ++ lt++-- | Select a faction leader. False, if nothing to do.+pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool+pickLeader verbose aid = do+  mleader <- getsClient sleader+  if mleader == Just aid+    then return False -- already picked+    else do+      body <- getsState $ getActorBody aid+      bodyUI <- getsSession $ getActorUI aid+      let !_A = assert (not (bproj body)+                        `blame` "projectile chosen as the pointman"+                        `swith` (aid, body)) ()+      -- Even if it's already the leader, give his proper name, not 'you'.+      let subject = partActor bodyUI+      when verbose $+        msgAdd MsgPointmanSwap $ makeSentence [subject, "picked as a pointman"]+      -- Update client state.+      updateClientLeader aid+      -- Move the xhair, if active, to the new level.+      modifySession $ \sess -> sess {saimMode =+        (\aimMode -> aimMode {aimLevelId = blid body}) <$> saimMode sess}+      -- Inform about items, etc.+      saimMode <- getsSession saimMode+      when verbose $+        if isJust saimMode+        then doLook+        else do+          (itemsBlurb, _) <-+            lookAtItems True (bpos body) (blid body) (Just aid) Nothing+          stashBlurb <- lookAtStash (bpos body) (blid body)+          msgAdd MsgAtFeetMinor $ stashBlurb <+> itemsBlurb+      return True++-- | Perform look around in the current position of the xhair.+-- Does nothing outside aiming mode.+doLook :: MonadClientUI m => m ()+doLook = do+  saimMode <- getsSession saimMode+  case saimMode of+    Just aimMode -> do+      let lidV = aimLevelId aimMode+      mxhairPos <- mxhairToPos+      xhairPos <- xhairToPos+      blurb <- lookAtPosition xhairPos lidV+      itemSel <- getsSession sitemSel+      mleader <- getsClient sleader+      outOfRangeBlurb <- case (itemSel, mxhairPos, mleader) of+        (Just (iid, _, _), Just pos, Just leader) -> do+          b <- getsState $ getActorBody leader+          if lidV /= blid b  -- no range warnings on remote levels+             || detailLevel aimMode < DetailHigh  -- no spam+          then return []+          else do+            itemFull <- getsState $ itemToFull iid+            let arItem = aspectRecordFull itemFull+            return [ (MsgPromptGeneric, "This position is out of range when flinging the selected item.")+                   | 1 + IA.totalRange arItem (itemKind itemFull)+                     < chessDist (bpos b) pos ]+        _ -> return []+      mapM_ (uncurry msgAdd) $ blurb ++ outOfRangeBlurb+    _ -> return ()++pickLeaderWithPointer :: MonadClientUI m => ActorId -> m MError+pickLeaderWithPointer leader = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  lidV <- viewedLevelUI+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  arena <- getArenaUI+  sactorUI <- getsSession sactorUI+  ours <- getsState $ filter (not . bproj . snd)+                      . actorAssocs (== side) lidV+  let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours+      viewed = sortOn keySelected oursUI+      banned = bannedPointmanSwitchBetweenLevels fact+      pick (aid, b) = if blid b /= arena && banned+                      then failMsg $ showReqFailure NoChangeDunLeader+                      else do+                        void $ pickLeader True aid+                        return Nothing+  pUI <- getsSession spointer+  let p@(Point px py) = squareToMap $ uiToSquare pUI+  -- Pick even if no space in status line for the actor's symbol.+  if | py == rheight - 2 && px == 0 -> pointmanCycle leader True Forward+     | py == rheight - 2 ->+         case drop (px - 1) viewed of+           [] -> return Nothing+             -- relaxed, due to subtleties of display of selected actors+           (aid, b, _) : _ -> pick (aid, b)+     | otherwise ->+         case find (\(_, b, _) -> bpos b == p) oursUI of+           Nothing -> failMsg "not pointing at an actor"+           Just (aid, b, _) -> pick (aid, b)++itemOverlayFromState :: LevelId -> [(ItemId, ItemQuant)] -> Bool+                     -> CCUI -> FactionId -> DiscoveryBenefit -> FontSetup+                     -> State+                     -> OKX+itemOverlayFromState arena iids displayRanged sccui side discoBenefit+                     FontSetup{..} s =+  let CCUI{coscreen=ScreenContent{rwidth}} = sccui+      localTime = getLocalTime arena s+      itemToF = flip itemToFull s+      factionD = sfactionD s+      attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor}+      markEqp periodic k ncha =+        if | periodic -> '"'  -- if equipped, no charges+           | ncha == 0 -> '-'  -- no charges left+           | k > ncha -> '~'  -- not all charges left+           | otherwise -> '+'+      pr :: MenuSlot -> (ItemId, ItemQuant)+         -> (AttrString, AttrString, KeyOrSlot)+      pr c (iid, kit@(k, _)) =+        let itemFull = itemToF iid+            arItem = aspectRecordFull itemFull+            colorSymbol =+              if IA.checkFlag Ability.Condition arItem+              then viewItemBenefitColored discoBenefit iid itemFull+              else viewItem itemFull+            phrase = makePhrase+              [partItemWsRanged rwidth side factionD displayRanged+                                DetailLow 4 k localTime itemFull kit]+            ncha = ncharges localTime kit+            periodic = IA.checkFlag Ability.Periodic arItem+            !cLab = Color.AttrChar { acAttr = attrCursor+                                   , acChar = markEqp periodic k ncha }+            asLab = [Color.attrCharToW32 cLab]+                    ++ [Color.spaceAttrW32 | isSquareFont propFont]+                    ++ [colorSymbol]+            !tDesc = " " <> phrase+        in (asLab, textToAS tDesc, Right c)+      l = zipWith pr natSlots iids+  in labDescOKX squareFont propFont l++-- | Extract whole-dungeon statistics for each place kind,+-- counting the number of occurrences of each type of+-- `Game.LambdaHack.Content.PlaceKind.PlaceEntry`+-- for the given place kind and gathering the set of levels+-- on which any entry for that place kind can be found.+placesFromState :: ContentData PK.PlaceKind -> Bool -> State+                -> EM.EnumMap (ContentId PK.PlaceKind)+                              (ES.EnumSet LevelId, Int, Int, Int)+placesFromState coplace sexposePlaces s =+  let addEntries (!es1, !nEntries1, !nArounds1, !nExists1)+                 (!es2, !nEntries2, !nArounds2, !nExists2) =+        let !es = ES.union es1 es2+            !nEntries = nEntries1 + nEntries2+            !nArounds = nArounds1 + nArounds2+            !nExists = nExists1 + nExists2+        in (es, nEntries, nArounds, nExists)+      placesFromLevel :: (LevelId, Level)+                      -> EM.EnumMap (ContentId PK.PlaceKind)+                                    (ES.EnumSet LevelId, Int, Int, Int)+      placesFromLevel (!lid, Level{lentry}) =+        let f (PK.PEntry pk) em =+              EM.insertWith addEntries pk (ES.singleton lid, 1, 0, 0) em+            f (PK.PAround pk) em =+              EM.insertWith addEntries pk (ES.singleton lid, 0, 1, 0) em+            f (PK.PExists pk) em =+              EM.insertWith addEntries pk (ES.singleton lid, 0, 0, 1) em+        in EM.foldr' f EM.empty lentry+             -- go through place entrances and depending on the place+             -- add an entry for it, whether Entry/Around/Exists,+             -- the effect being we're counting #s of each type+      insertZeros !em !pk _ = EM.insert pk (ES.empty, 0, 0, 0) em+      -- The initial places are overwritten except for those+      -- that have no entries in the dungeon at all,+      -- and in `sexposePlaces` debug mode these will be shown even though+      -- the stats will be zeros (which is a valuable warning!).+      initialPlaces | not sexposePlaces = EM.empty+                    | otherwise = ofoldlWithKey' coplace insertZeros EM.empty+  in EM.unionWith addEntries+       initialPlaces+       (EM.unionsWith addEntries $ map placesFromLevel $ EM.assocs $ sdungeon s)+        -- gather per-place-kind statistics for each level,+        -- then aggregate them over all levels, remembering that the place+        -- appeared on the given level (but not how man times)++-- TODO: if faction not known, it's info should not be updated+-- by the server. But let's wait until server sends general state diffs+-- and then block diffs that don't apply, because faction is missing.+factionsFromState :: ItemRoles -> State -> [(FactionId, Faction)]+factionsFromState (ItemRoles itemRoles) s =+  let seenTrunks = ES.toList $ itemRoles EM.! STrunk+      trunkBelongs fid iid = jfid (getItemBody iid s) == Just fid+      factionSeen (fid, fact) = not (EM.null (gvictims fact))  -- shortcut+                                || any (trunkBelongs fid) seenTrunks+  in filter factionSeen $ EM.assocs $ sfactionD s++itemOverlay :: MonadClientUI m+            => [(ItemId, ItemQuant)] -> ItemDialogMode -> m OKX+itemOverlay iids dmode = do+  sccui <- getsSession sccui+  side <- getsClient sside+  arena <- getArenaUI+  discoBenefit <- getsClient sdiscoBenefit+  fontSetup <- getFontSetup+  let displayRanged =+        dmode `elem` [ MStore CGround, MStore CEqp, MStore CStash+                     , MOwned, MLore SItem, MLore SBlast ]+  okx <- getsState $ itemOverlayFromState arena iids displayRanged+                                          sccui side discoBenefit fontSetup+  return $! okx++skillsOverlay :: MonadClientUI m => ActorId -> m OKX+skillsOverlay aid = do+  b <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  FontSetup{..} <- getFontSetup+  let prSlot :: MenuSlot -> Ability.Skill+             -> ((AttrLine, (Int, AttrLine), (Int, AttrLine)), KYX)+      prSlot c skill =+        let skName = " " <> skillName skill+            attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor}+            labAc = Color.AttrChar { acAttr = attrCursor+                                   , acChar = '+' }+            lab = attrStringToAL [Color.attrCharToW32 labAc]+            labLen = textSize squareFont $ attrLine lab+            indentation = if isSquareFont propFont then 52 else 26+            valueText = skillToDecorator skill b+                        $ Ability.getSk skill actorMaxSk+            triple = ( lab+                     , (labLen, textToAL skName)+                     , (indentation, textToAL valueText) )+            lenButton = 26 + T.length valueText+        in (triple, (Right c, ( PointUI 0 (fromEnum c)+                              , ButtonWidth propFont lenButton )))+      (ts, kxs) = unzip $ zipWith prSlot natSlots skillsInDisplayOrder+      (skLab, skDescr, skValue) = unzip3 ts+      skillLab = EM.singleton squareFont $ offsetOverlay skLab+      skillDescr = EM.singleton propFont $ offsetOverlayX skDescr+      skillValue = EM.singleton monoFont $ offsetOverlayX skValue+  return (EM.unionsWith (++) [skillLab, skillDescr, skillValue], kxs)++placesOverlay :: MonadClientUI m => m OKX+placesOverlay = do+  COps{coplace} <- getsState scops+  soptions <- getsClient soptions+  FontSetup{..} <- getFontSetup+  places <- getsState $ placesFromState coplace (sexposePlaces soptions)+  let prSlot :: MenuSlot+             -> (ContentId PK.PlaceKind, (ES.EnumSet LevelId, Int, Int, Int))+             -> (AttrString, AttrString, KeyOrSlot)+      prSlot c (pk, (es, _, _, _)) =+        let name = PK.pname $ okind coplace pk+            labChar = if ES.null es then '-' else '+'+            attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor}+            labAc = Color.AttrChar { acAttr = attrCursor+                                   , acChar = labChar }+            -- Bang required to free @places@ as you go.+            !asLab = [Color.attrCharToW32 labAc]+            !tDesc = " "+                     <> name+                     <+> if ES.null es+                         then ""+                         else "("+                              <> makePhrase [MU.CarWs (ES.size es) "level"]+                              <> ")"+        in (asLab, textToAS tDesc, Right c)+      l = zipWith prSlot natSlots $ EM.assocs places+  return $! labDescOKX squareFont propFont l++factionsOverlay :: MonadClientUI m => m OKX+factionsOverlay = do+  FontSetup{..} <- getFontSetup+  sroles <- getsSession sroles+  factions <- getsState $ factionsFromState sroles+  let prSlot :: MenuSlot+             -> (FactionId, Faction)+             -> (AttrString, AttrString, KeyOrSlot)+      prSlot c (_, fact) =+        let name = FK.fname $ gkind fact  -- we ignore "Controlled", etc.+            gameOver = isJust $ gquit fact+            labChar = if gameOver then '-' else '+'+            attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor}+            labAc = Color.AttrChar { acAttr = attrCursor+                                   , acChar = labChar }+            !asLab = [Color.attrCharToW32 labAc]+            !tDesc = " "+                     <> name+                     <+> case gquit fact of+                           Just Status{stOutcome} | not $ isHorrorFact fact ->+                             "(" <> FK.nameOutcomePast stOutcome <> ")"+                           _ -> ""+        in (asLab, textToAS tDesc, Right c)+      l = zipWith prSlot natSlots factions+  return $! labDescOKX squareFont propFont l++modesOverlay :: MonadClientUI m => m OKX+modesOverlay = do+  COps{comode} <- getsState scops+  FontSetup{..} <- getFontSetup+  svictories <- getsSession svictories+  nxtChal <- getsClient snxtChal  -- mark victories only for current difficulty+  let f !acc _p !i !a = (i, a) : acc+      campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f []+      prSlot :: MenuSlot+             -> (ContentId MK.ModeKind, MK.ModeKind)+             -> (AttrString, AttrString, KeyOrSlot)+      prSlot c (gameModeId, gameMode) =+        let modeName = MK.mname gameMode+            victories = case EM.lookup gameModeId svictories of+              Nothing -> 0+              Just cm -> fromMaybe 0 (M.lookup nxtChal cm)+            labChar = if victories > 0 then '-' else '+'+            attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor}+            labAc = Color.AttrChar { acAttr = attrCursor+                                   , acChar = labChar }+            !asLab = [Color.attrCharToW32 labAc]+            !tDesc = " " <> modeName+        in (asLab, textToAS tDesc, Right c)+      l = zipWith prSlot natSlots campaignModes+  return $! labDescOKX squareFont propFont l++describeMode :: MonadClientUI m+             => Bool -> ContentId MK.ModeKind+             -> m (EM.EnumMap DisplayFont Overlay)+describeMode addTitle gameModeId = do+  COps{comode} <- getsState scops+  CCUI{coscreen=ScreenContent{rwidth}}+    <- getsSession sccui+  FontSetup{..} <- getFontSetup+  scoreDict <- getsState shigh+  scampings <- getsSession scampings+  srestarts <- getsSession srestarts+  side <- getsClient sside+  total <- getsState $ snd . calculateTotal side+  dungeonTotal <- getsState sgold+  let screensaverBlurb = "This is one of the screensaver scenarios, not available from the main menu, with all factions controlled by AI. Feel free to take over or relinquish control at any moment, but to register a legitimate high score, choose a standard scenario instead.\n"+  let gameMode = okind comode gameModeId+      duplicateEOL '\n' = "\n\n"+      duplicateEOL c = T.singleton c+      sections =+        [ ( textFgToAS Color.BrGreen "The story so far:"+          , T.concatMap duplicateEOL (MK.mdesc gameMode) )+        , ( textFgToAS Color.cMeta "Rules of the game:"+          , MK.mrules gameMode )+        , ( textFgToAS Color.BrCyan "Running commentary:"+          , T.concatMap duplicateEOL+              (if MK.mattract gameMode+               then screensaverBlurb <> MK.mreason gameMode+               else MK.mreason gameMode) )+        , ( textFgToAS Color.cGreed "Hints, not needed unless stuck:"+          , T.concatMap duplicateEOL (MK.mhint gameMode) )+        ]+      renderSection :: (AttrString, Text) -> Maybe [(DisplayFont, AttrString)]+      renderSection (header, desc) =+        if T.null desc+        then Nothing+        else Just [(monoFont, header), (propFont, textToAS desc)]+      survivingHow = if | total == 0 -> "(barely)"+                        | total < dungeonTotal `div` 2 -> "(so far)"+                        | otherwise -> ""+      title = if addTitle+              then "\nYou are"+                   <+> survivingHow+                   <+> "surviving the '"+                   <> MK.mname gameMode+                   <> "' adventure.\n"+              else ""+      blurb = map (second $ splitAttrString (rwidth - 2) (rwidth - 2)) $+        (propFont, textToAS (title <> "\n"))+        : intercalate [(monoFont, textToAS "\n")]+                       (mapMaybe renderSection sections)+      -- Colour is used to delimit the section when displayed in one+      -- column, when using square fonts only.+      blurbEnd = map (second $ splitAttrString (rwidth - 2) (rwidth - 2)) $+        ( propFont+        , textFgToAS Color.Brown+                     "\nThis adventure's endings experienced so far:\n\n" )+          : if null sectionsEndAS+            then [(monoFont, textToAS "*none*")]+            else sectionsEndAS+      sectionsEndAS = intercalate [(monoFont, textToAS "\n")]+                                  (mapMaybe renderSection sectionsEnd)+      sectionsEnd = map outcomeSection [minBound..maxBound]+      outcomeSection :: FK.Outcome -> (AttrString, Text)+      outcomeSection outcome =+        ( renderOutcome outcome+        , if not (outcomeSeen outcome)+          then ""  -- a possible spoiler and lack of sense of progression+          else T.concatMap duplicateEOL+               $ fromMaybe "" $ lookup outcome+               $ MK.mendMsg gameMode ++ endMsgDefault  -- left-biased+        )+      -- These are not added to @mendMsg@, because they only fit here.+      endMsgDefault =+        [ (FK.Restart, "No shame there is in noble defeat and there is honour in perseverance. Sometimes there are ways and places to turn rout into victory.")+        , (FK.Camping, "Don't fear to take breaks. While you move, others move, even on distant floors, but while you stay still, the world stays still.")+        ]+      scoreRecords = maybe [] HighScore.unTable $ EM.lookup gameModeId scoreDict+      -- This doesn't use @svictories@, but high scores, because high scores+      -- are more persistent and granular (per-outcome). OTOH, @svictories@+      -- are per-challenge, which is important in other cases.+      -- @Camping@ and @Restart@ are fine to be less persistent.+      outcomeSeen :: FK.Outcome -> Bool+      outcomeSeen outcome = case outcome of+        FK.Camping -> gameModeId `ES.member` scampings+        FK.Restart -> gameModeId `ES.member` srestarts+        _ -> outcome `elem` map (stOutcome . HighScore.getStatus) scoreRecords+      -- Camping not taken into account.+      lastOutcome :: FK.Outcome+      lastOutcome = if null scoreRecords+                    then FK.Restart  -- only if nothing else+                    else stOutcome . HighScore.getStatus+                         $ maximumBy (comparing HighScore.getDate) scoreRecords+      renderOutcome :: FK.Outcome -> AttrString+      renderOutcome outcome =+        let color | outcome `elem` FK.deafeatOutcomes = Color.cVeryBadEvent+                  | outcome `elem` FK.victoryOutcomes = Color.cVeryGoodEvent+                  | otherwise = Color.cNeutralEvent+            lastRemark+              | outcome /= lastOutcome = ""+              | outcome `elem` FK.deafeatOutcomes = "(last suffered ending)"+              | outcome `elem` FK.victoryOutcomes = "(last achieved ending)"+              | otherwise = "(last seen ending)"+        in textToAS "Game over message when"+           <+:> (textFgToAS color (T.toTitle $ FK.nameOutcomePast outcome)+                 <+:> textToAS lastRemark)+           <> textToAS ":"+  return $! if isSquareFont propFont+            then EM.singleton squareFont  -- single column, single font+                 $ xtranslateOverlay 2 $ offsetOverlay+                 $ concatMap snd $ blurb ++ blurbEnd+            else EM.unionWith (++)+                 (EM.map (xtranslateOverlay 1)+                  $ attrLinesToFontMap blurb)+                 (EM.map (xtranslateOverlay $ rwidth + 1)+                  $ attrLinesToFontMap blurbEnd)++pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int)+pickNumber askNumber kAll = assert (kAll >= 1) $ do+  let shownKeys = [ K.returnKM, K.spaceKM, K.mkChar '+', K.mkChar '-'+                  , K.backspaceKM, K.escKM ]+      frontKeyKeys = shownKeys ++ map K.mkChar ['0'..'9']+      gatherNumber kCur = assert (1 <= kCur && kCur <= kAll) $ do+        let kprompt = "Choose number:" <+> tshow kCur+        msgAdd MsgPromptGeneric kprompt+        sli <- reportToSlideshow shownKeys+        ekkm <- displayChoiceScreen "" ColorFull False sli frontKeyKeys+        case ekkm of+          Left kkm ->+            case K.key kkm of+              K.Char '+' ->+                gatherNumber $ if kCur + 1 > kAll then 1 else kCur + 1+              K.Char '-' ->+                gatherNumber $ if kCur - 1 < 1 then kAll else kCur - 1+              K.Char l | kCur * 10 + Char.digitToInt l > kAll ->+                gatherNumber $ if Char.digitToInt l == 0+                               then kAll+                               else min kAll (Char.digitToInt l)+              K.Char l -> gatherNumber $ kCur * 10 + Char.digitToInt l+              K.BackSpace -> gatherNumber $ max 1 (kCur `div` 10)+              K.Return -> return $ Right kCur+              K.Esc -> weaveJust <$> failWith "never mind"+              K.Space -> return $ Left Nothing+              _ -> error $ "unexpected key" `showFailure` kkm+          Right slot -> error $ "unexpected menu slot" `showFailure` slot+  if kAll == 1 || not askNumber+  then return $ Right kAll+  else do+    res <- gatherNumber kAll+    case res of+      Right k | k <= 0 -> error $ "" `showFailure` (res, kAll)+      _ -> return res++-- | Produces a textual description of the tile at a position.+lookAtTile :: MonadClientUI m+           => Bool             -- ^ can be seen right now?+           -> Point            -- ^ position to describe+           -> LevelId          -- ^ level the position is at+           -> Maybe ActorId    -- ^ the actor that looks+           -> Maybe MU.Person  -- ^ grammatical person of the item(s), if any+           -> m (Text, Text, [(Int, MU.Part)])+lookAtTile canSee p lidV maid mperson = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  cops@COps{cotile, coplace} <- getsState scops+  side <- getsClient sside+  factionD <- getsState sfactionD+  mb <- getsState $ \s -> flip getActorBody s <$> maid+  lvl <- getLevel lidV+  saimMode <- getsSession saimMode+  embeds <- getsState $ getEmbedBag lidV p+  itemToF <- getsState $ flip itemToFull+  seps <- getsClient seps+  localTime <- getsState $ getLocalTime lidV+  getKind <- getsState $ flip getIidKind+  let inhabitants = posToAidsLvl p lvl+      detail = maybe DetailAll detailLevel saimMode+      aims = isJust $ (\b -> makeLine False b p seps cops lvl) =<< mb+      tkid = lvl `at` p+      tile = okind cotile tkid+      vis | TK.tname tile == "unknown space" = "that is"+          | not (null inhabitants)+            && (bpos <$> mb) /= Just p = "the terrain here is"+          | not canSee = "you remember"+          | not aims = "you are aware of"  -- walkable path a proxy for in LOS+          | otherwise = "you see"+      vperson = case mperson of+        Nothing -> vis+        Just MU.Sg1st -> error "an item speaks in first person"+        Just MU.Sg3rd -> "It is laying on"+        Just MU.PlEtc -> "They lay on"+      tilePart = MU.AW $ MU.Text $ TK.tname tile+      entrySentence pk blurb =+        makeSentence [blurb, MU.Text $ PK.pname $ okind coplace pk]+      placeBlurb = case EM.lookup p $ lentry lvl of+        Nothing -> ""+        Just (PK.PEntry pk) -> entrySentence pk "it is an entrance to"+        Just (PK.PAround pk) -> entrySentence pk "it surrounds"+        Just (PK.PExists _) -> ""+      embedLook (iid, kit@(k, _)) =+        let itemFull = itemToF iid+            nWs = partItemWsDetail detail+                                   rwidth side factionD k localTime itemFull kit+        in (k, nWs)+      embedKindList =+        map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds)+      embedList = map embedLook $ sortEmbeds cops tkid embedKindList+  return (makeSentence [vperson, tilePart], placeBlurb, embedList)++-- | Produces a textual description of actors at a position.+lookAtActors :: MonadClientUI m+             => Point      -- ^ position to describe+             -> LevelId    -- ^ level the position is at+             -> m (Text, Maybe (MU.Part, Bool), Text)+lookAtActors p lidV = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  side <- getsClient sside+  inhabitants <- getsState $ posToAidAssocs p lidV+  factionD <- getsState sfactionD+  localTime <- getsState $ getLocalTime lidV+  saimMode <- getsSession saimMode+  let detail = maybe DetailAll detailLevel saimMode+  case inhabitants of+    [] -> return ("", Nothing, "")+    (aid, body) : rest -> do+      actorPronoun <- partPronounLeader aid+      itemFull <- getsState $ itemToFull $ btrunk body+      guardVerbs <- getsState $ guardItemVerbs body+      subjects <- mapM (partActorLeader . fst) inhabitants+      let bfact = factionD EM.! bfid body+          -- No "a" prefix even if singular and inanimate, to distinguish+          -- from items lying on the floor (and to simplify code).+          (subject, person) = squashedWWandW subjects+          resideVerb = case bwatch body of+            WWatch -> "be here"+            WWait 0 -> "idle here"+            WWait _ -> "brace for impact"+            WSleep -> "sleep here"+            WWake -> "be waking up"+          flyVerb | bproj body = "zip through here"+                  | isJust $ btrajectory body = "move through here"+                  | otherwise = resideVerb+          verbs = flyVerb : guardVerbs+          projDesc | not (bproj body) || detail < DetailHigh = ""+                   | otherwise =+            let kit = beqp body EM.! btrunk body+                ps = [partItemMediumAW rwidth side factionD localTime+                                       itemFull kit]+                tailWords = tail . T.words . makePhrase+            in if tailWords ps == tailWords subjects+               then ""+               else makeSentence $ "this is" : ps+          factDesc = case jfid $ itemBase itemFull of+            Just tfid | tfid /= bfid body ->+              let dominatedBy = if bfid body == side then "us" else gname bfact+                  tfact = factionD EM.! tfid+              in "Originally of" <+> gname tfact+                 <> ", now fighting for" <+> dominatedBy <> "."+            _ | detail < DetailHigh -> ""  -- only domination worth spamming+            _ | bfid body == side -> ""  -- just one of us+            _ | bproj body -> "Launched by" <+> gname bfact <> "."+            _ -> "One of" <+> gname bfact <> "."+          idesc = if detail < DetailHigh+                  then ""+                  else IK.idesc $ itemKind itemFull+          -- If many different actors, only list names.+          sameTrunks = all (\(_, b) -> btrunk b == btrunk body) rest+          desc = wrapInParens $ projDesc <+> factDesc <+> idesc+          onlyIs = bwatch body == WWatch && null guardVerbs+          allBlurb = makeSentence [MU.SubjectVVxV "and" person MU.Yes+                                                  subject verbs]+          headBlurb = makeSentence [MU.SubjectVVxV "and" MU.Sg3rd MU.Yes+                                                   (head subjects) verbs]+          andProjectiles = case subjects of+            _ : projs@(_ : _) ->+              let (subjectProjs, personProjs) =+                    squashedWWandW projs+              in makeSentence+                   [MU.SubjectVerb personProjs MU.Yes+                                   subjectProjs "can be seen"]+            _ -> ""+          actorAlive = bhp body >= 0+          mactorPronounAlive =+            if bproj body then Nothing else Just (actorPronoun, actorAlive)+      return $!+        if | not actorAlive && not (bproj body) ->+             ( makeSentence+                 (MU.SubjectVerbSg (head subjects) "lie here"+                  : if null guardVerbs+                    then []+                    else [ MU.SubjectVVxV "and" MU.Sg3rd MU.No+                                          "and" guardVerbs+                         , "any more" ])+             , mactorPronounAlive+             , wrapInParens desc <+> andProjectiles )+           | sameTrunks ->  -- only non-proj or several similar projectiles+             ( allBlurb+             , mactorPronounAlive+             , desc )+           | not (bproj body) && onlyIs ->+             ( headBlurb+             , mactorPronounAlive+             , desc <+> andProjectiles )+           | not (bproj body) ->+             ( makeSentence [subject, "can be seen"] <+> headBlurb+             , mactorPronounAlive+             , desc )+           | otherwise -> assert (bproj body && not (null rest))+             ( makeSentence [subject, "can be seen"]+             , Nothing+             , "" )++guardItemVerbs :: Actor -> State -> [MU.Part]+guardItemVerbs body s =+  -- We only hint while, in reality, currently the client knows+  -- all the items in eqp of the foe. But we may remove the knowledge+  -- in the future and, anyway, it would require a dedicated+  -- UI mode beyond a couple of items per actor.+  let itemsSize = guardItemSize body s+      belongingsVerbs | itemsSize == 1 = ["fondle a trinket"]+                      | itemsSize > 1 = ["haul a hoard"]+                      | otherwise = []+  in if bproj body then [] else belongingsVerbs++guardItemSize :: Actor -> State -> Int+guardItemSize body s =+  let toReport iid =+        let itemKind = getIidKind iid s+        in fromMaybe 0 (lookup IK.UNREPORTED_INVENTORY (IK.ifreq itemKind)) <= 0+  in length $ filter toReport $ EM.keys (beqp body)++-- | Produces a textual description of items at a position.+lookAtItems :: MonadClientUI m+            => Bool     -- ^ can be seen right now?+            -> Point    -- ^ position to describe+            -> LevelId  -- ^ level the position is at+            -> Maybe ActorId+                        -- ^ the actor that looks+            -> Maybe (MU.Part, Bool)+                        -- ^ pronoun for the big actor at the position, if any,+                        --   and whether the big actor is alive+            -> m (Text, Maybe MU.Person)+lookAtItems canSee p lidV maid mactorPronounAlive = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  side <- getsClient sside+  itemToF <- getsState $ flip itemToFull+  mb <- getsState $ \s -> flip getActorBody s <$> maid+  -- Not using @viewedLevelUI@, because @aid@ may be temporarily not a leader.+  saimMode <- getsSession saimMode+  let standingOn = Just p == (bpos <$> mb) && Just lidV == (blid <$> mb)+      -- In exploration mode the detail level depends on whether the actor+      -- that looks stand over the items, because then he can check details+      -- with inventory commands (or look in aiming mode).+      detailExploration = if standingOn && Just side == (bfid <$> mb)+                          then DetailLow+                          else DetailAll+      detail = maybe detailExploration detailLevel saimMode+  localTime <- getsState $ getLocalTime lidV+  is <- getsState $ getFloorBag lidV p+  factionD <- getsState sfactionD+  globalTime <- getsState stime+  getKind <- getsState $ flip getIidKindId+  mLeader <- case maid of+    Just aid | standingOn -> do+      leaderPronoun <- partPronounLeader aid+      return $ Just (leaderPronoun, (bhp <$> mb) >= Just 0)+    _ -> return Nothing+  let mactorPronounAliveLeader = mactorPronounAlive <|> mLeader+  (subject, verb) <- case mactorPronounAliveLeader of+    Just (actorPronoun, actorAlive) ->+      return (actorPronoun, if actorAlive then "stand over" else "fall over")+    Nothing -> case maid of+      Just aid -> do+        subjectAid <- partActorLeader aid+        return (subjectAid, if canSee then "notice" else "remember")+      Nothing ->+        return ("one", if canSee then "can see" else "may remember")+  let nWs (iid, kit@(k, _)) =+        partItemWsDetail detail+                         rwidth side factionD k localTime (itemToF iid) kit+      (object, person) = case EM.assocs is of+        ii : _ : _ : _ | detail <= DetailMedium ->+          (MU.Phrase [nWs ii, "and other items"], MU.PlEtc)+        [ii@(_, (1, _))] -> (nWs ii, MU.Sg3rd)+        iis -> (MU.WWandW $ map nWs $ sortOn (getKind . fst) iis, MU.PlEtc)+  -- Here @squashedWWandW@ is not needed, because identical items at the same+  -- position are already merged in the floor item bag and multiple identical+  -- messages concerning different positions are merged with <x7>+  -- to distinguish from a stack of items at a single position.+  return ( if EM.null is || globalTime == timeZero+           then ""+           else makeSentence [MU.SubjectVerbSg subject (MU.Text verb), object]+         , if isNothing mactorPronounAlive then Just person else Nothing )++lookAtStash :: MonadClientUI m => Point -> LevelId -> m Text+lookAtStash p lidV = do+  side <- getsClient sside+  factionD <- getsState sfactionD+  let locateStash (fid, fact) = case gstash fact of+        Just (lid, pos) | lid == lidV  && pos == p ->+          Just $ if fid == side+                 then "Here is the shared inventory stash of your team."+                 else gname fact+                      <+> "set up their shared inventory stash here."+        _ -> Nothing+  return $! T.intercalate " " $ mapMaybe locateStash $ EM.assocs factionD++-- | Produces a textual description of everything at the requested+-- level's position.+lookAtPosition :: MonadClientUI m+               => Point -> LevelId -> m [(MsgClassShow, Text)]+lookAtPosition p lidV = do+  COps{cotile} <- getsState scops+  side <- getsClient sside+  per <- getPerFid lidV+  let canSee = ES.member p (totalVisible per)+  (actorsBlurb, mactorPronounAlive, actorsDesc) <- lookAtActors p lidV+  mleader <- getsClient sleader+  (itemsBlurb, mperson) <-+    lookAtItems canSee p lidV mleader mactorPronounAlive+  let tperson = if T.null itemsBlurb then Nothing else mperson+  (tileBlurb, placeBlurb, embedsList) <-+    lookAtTile canSee p lidV mleader tperson+  inhabitants <- getsState $ posToAidAssocs p lidV+  let actorMsgClass =+        if (bfid . snd <$> inhabitants) == [side]+        then MsgPromptGeneric  -- our single proj or non-proj; tame+        else MsgPromptActors+  stashBlurb <- lookAtStash p lidV+  lvl@Level{lsmell, ltime} <- getLevel lidV+  saimMode <- getsSession saimMode+  let detail = maybe DetailAll detailLevel saimMode+      smellBlurb = case EM.lookup p lsmell of+        Just sml | sml > ltime ->+          let Delta t = smellTimeout `timeDeltaSubtract`+                          (sml `timeDeltaToFrom` ltime)+              seconds = t `timeFitUp` timeSecond+          in "A smelly body passed here around" <+> tshow seconds <> "s ago."+        _ -> ""+  embeds <- getsState $ getEmbedBag lidV p+  getKind <- getsState $ flip getIidKind+  let ppEmbedName :: (Int, MU.Part) -> Text+      ppEmbedName (k, part) =+        let verb = if k == 1 then "is" else "are"+        in makeSentence ["There", verb, part]+      embedKindList = map (\(iid, kit) -> (getKind iid, (iid, kit)))+                          (EM.assocs embeds)+      feats = TK.tfeature $ okind cotile $ lvl `at` p+      tileActions = mapMaybe (parseTileAction False False embedKindList)+                             feats+      isEmbedAction EmbedAction{} = True+      isEmbedAction _ = False+      embedVerb = [ "activated"+                  | any isEmbedAction tileActions+                    && any (\(itemKind, _) -> not $ null $ IK.ieffects itemKind)+                           embedKindList ]+      isToAction ToAction{} = True+      isToAction _ = False+      isWithAction WithAction{} = True+      isWithAction _ = False+      isEmptyWithAction (WithAction [] _) = True+      isEmptyWithAction _ = False+      alterVerb | any isEmptyWithAction tileActions = ["very easily modified"]+                | any isToAction tileActions = ["easily modified"]+                | any isWithAction tileActions = ["potentially modified"]+                | otherwise = []+      verbs = embedVerb ++ alterVerb+      alterBlurb = if null verbs+                   then ""+                   else makeSentence ["can be", MU.WWandW verbs]+      toolFromAction (WithAction grps _) = Just grps+      toolFromAction _ = Nothing+      toolsToAlterWith = mapMaybe toolFromAction tileActions+      tItems = describeToolsAlternative toolsToAlterWith+      transformBlurb = if T.null tItems+                       then ""+                       else "The following items on the ground or in equipment enable special transformations:"+                            <+> tItems <> "."  -- not telling to what terrain+      modifyBlurb = alterBlurb <+> transformBlurb+      midEOL = if detail < DetailMedium+                  || T.null stashBlurb && T.null actorsDesc+                  || T.null smellBlurb && T.null itemsBlurb+                  || null embedsList && T.null modifyBlurb+               then ""+               else "\n"+      ms = [ (MsgPromptAction, stashBlurb)+           , (actorMsgClass, actorsBlurb)+           , (MsgPromptGeneric, actorsDesc <> midEOL) ]+           ++ [(MsgPromptGeneric, smellBlurb) | detail >= DetailMedium]+           ++ [(MsgPromptItems, itemsBlurb <> midEOL)]+           ++ [(MsgPromptFocus, tileBlurb) | detail >= DetailMedium+                                             || detail == DetailLow+                                                && not (null embedsList)]+           ++ [(MsgPromptGeneric, placeBlurb) | detail >= DetailMedium]+           ++ case detail of+                DetailLow -> []  -- not to obscure aiming line+                _ -> let n = sum $ map fst embedsList+                         wWandW = MU.WWandW $ map snd embedsList+                     in [(MsgPromptMention, ppEmbedName (n, wWandW)) | n > 0]+           ++ [(MsgPromptModify, modifyBlurb) | detail >= DetailHigh]+  return $! if all (T.null . snd) ms && detail > DetailLow+            then [(MsgPromptFocus, tileBlurb)]+            else ms++displayOneMenuItem :: MonadClientUI m+                   => (MenuSlot -> m OKX) -> [K.KM] -> Int -> MenuSlot+                   -> m K.KM+displayOneMenuItem renderOneItem extraKeys slotBound slot = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  let keys = [K.spaceKM, K.escKM]+             ++ [K.upKM | fromEnum slot > 0]+             ++ [K.downKM | fromEnum slot < slotBound]+             ++ extraKeys+  okx <- renderOneItem slot+  slides <- overlayToSlideshow (rheight - 2) keys okx+  km <- getConfirms ColorFull keys slides+  case K.key km of+    K.Up -> displayOneMenuItem renderOneItem extraKeys slotBound $ pred slot+    K.Down -> displayOneMenuItem renderOneItem extraKeys slotBound $ succ slot+    _ -> return km++okxItemLoreInline :: MonadClientUI m+                  => (ItemId -> ItemFull -> Int -> Text)+                  -> Int -> ItemDialogMode -> [(ItemId, ItemQuant)]+                  -> Int -> MenuSlot+                  -> m OKX+okxItemLoreInline promptFun meleeSkill dmode iids widthRaw slot = do+  FontSetup{..} <- getFontSetup+  let (iid, kit@(k, _)) = iids !! fromEnum slot+      -- Some prop fonts are wider than mono (e.g., in dejavuBold font set),+      -- so the width in these artificial texts full of digits and strange+      -- characters needs to be smaller than @rwidth - 2@ that would suffice+      -- for mono.+      width = widthRaw - 5+  itemFull <- getsState $ itemToFull iid+  (ovLab, ovDesc) <- itemDescOverlays True meleeSkill dmode iid kit itemFull+                                      width+  let prompt = promptFun iid itemFull k+      promptBlurb | T.null prompt = []+                  | otherwise = offsetOverlay $ splitAttrString width width+                                $ textFgToAS Color.Brown $ prompt <> "\n\n"+      len = length promptBlurb+      descSym2 = ytranslateOverlay len ovLab+      descBlurb2 = promptBlurb ++ ytranslateOverlay len ovDesc+      ov = EM.insertWith (++) squareFont descSym2+           $ EM.singleton propFont descBlurb2+  return (ov, [])++okxItemLoreMsg :: MonadClientUI m+               => (ItemId -> ItemFull -> Int -> Text)+               -> Int -> ItemDialogMode -> [(ItemId, ItemQuant)]+               -> MenuSlot+               -> m OKX+okxItemLoreMsg promptFun meleeSkill dmode iids slot = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  FontSetup{..} <- getFontSetup+  let (iid, kit@(k, _)) = iids !! fromEnum slot+  itemFull <- getsState $ itemToFull iid+  (ovLab, ovDesc) <- itemDescOverlays True meleeSkill dmode iid kit itemFull+                                      rwidth+  let prompt = promptFun iid itemFull k+  msgAdd MsgPromptGeneric prompt+  let ov = EM.insertWith (++) squareFont ovLab+           $ EM.singleton propFont ovDesc+  return (ov, [])++itemDescOverlays :: MonadClientUI m+                 => Bool -> Int -> ItemDialogMode -> ItemId -> ItemQuant+                 -> ItemFull -> Int+                 -> m (Overlay, Overlay)+itemDescOverlays markParagraphs meleeSkill dmode iid kit itemFull width = do+  FontSetup{squareFont} <- getFontSetup+  side <- getsClient sside+  arena <- getArenaUI+  localTime <- getsState $ getLocalTime arena+  factionD <- getsState sfactionD+  -- The hacky level 0 marks items never seen, but sent by server at gameover.+  jlid <- getsSession $ fromMaybe (toEnum 0) <$> EM.lookup iid . sitemUI+  let descAs = itemDesc width markParagraphs side factionD meleeSkill+                        dmode localTime jlid itemFull kit+  return $! labDescOverlay squareFont width descAs++cycleLore :: MonadClientUI m => [m K.KM] -> [m K.KM] -> m ()+cycleLore _ [] = return ()+cycleLore seen (m : rest) = do  -- @seen@ is needed for SPACE to end cycling+  km <- m+  if | km == K.spaceKM -> cycleLore (m : seen) rest+     | km == K.mkChar '>' -> if null rest+                             then cycleLore [] (reverse $ m : seen)+                             else cycleLore (m : seen) rest+     | km == K.mkChar '<' -> case seen of+                               prev : ps -> cycleLore ps (prev : m : rest)+                               [] -> case reverse (m : rest) of+                                 prev : ps -> cycleLore ps [prev]+                                 [] -> error "cycleLore: screens disappeared"+     | km == K.escKM -> return ()+     | otherwise -> error "cycleLore: unexpected key"++spoilsBlurb :: Text -> Int -> Int -> Text+spoilsBlurb currencyName total dungeonTotal =+  if | dungeonTotal == 0 ->+         "All the spoils of your team are of the practical kind."+     | total == 0 -> "Your team haven't found any genuine treasure yet."+     | otherwise -> makeSentence+         [ "your team's spoils are worth"+         , MU.CarAWs total $ MU.Text currencyName+         , "out of the rumoured total"+         , MU.Cardinal dungeonTotal ]++ppContainerWownW :: MonadClientUI m+                 => (ActorId -> m MU.Part) -> Bool -> Container -> m [MU.Part]+ppContainerWownW ownerFun addPrepositions c = case c of+  CFloor{} -> return ["nearby"]+  CEmbed{} -> return ["embedded nearby"]+  CActor aid store -> do+    side <- getsClient sside+    b <- getsState $ getActorBody aid+    owner <- ownerFun aid+    fidName <- getsState $ gname . (EM.! bfid b) . sfactionD+    let (preposition, noun) = ppCStore store+        prep = [MU.Text preposition | addPrepositions]+    return $! prep ++ case store of+      CGround -> MU.Text noun : if bproj b then [] else ["under", owner]+      CStash -> if bfid b /= side+                then [MU.WownW (MU.Text fidName) (MU.Text noun)]+                else [MU.Text noun]+      _ -> [MU.WownW owner (MU.Text noun)]+  CTrunk{} -> error $ "" `showFailure` c++nxtGameMode :: COps -> Int -> (ContentId MK.ModeKind, MK.ModeKind)+nxtGameMode COps{comode} snxtScenario =+  let f !acc _p !i !a = (i, a) : acc+      campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f []+  in campaignModes !! (snxtScenario `mod` length campaignModes)
+ engine-src/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs view
@@ -0,0 +1,2093 @@+-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd"+-- client commands that return server requests.+-- A couple of them do not take time, the rest does.+-- Here prompts and menus are displayed, but any feedback resulting+-- from the commands (e.g., from inventory manipulation) is generated later on,+-- by the server, for all clients that witness the results of the commands.+module Game.LambdaHack.Client.UI.HandleHumanGlobalM+  ( -- * Meta commands+    byAreaHuman, byAimModeHuman+  , composeIfLocalHuman, composeUnlessErrorHuman, compose2ndLocalHuman+  , loopOnNothingHuman, executeIfClearHuman+    -- * Global commands that usually take time+  , waitHuman, waitHuman10, yellHuman, moveRunHuman+  , runOnceAheadHuman, moveOnceToXhairHuman+  , runOnceToXhairHuman, continueToXhairHuman+  , moveItemHuman, projectHuman, applyHuman+  , alterDirHuman, alterWithPointerHuman, closeDirHuman+  , helpHuman, hintHuman, dashboardHuman, itemMenuHuman, chooseItemMenuHuman+  , mainMenuHuman, mainMenuAutoOnHuman, mainMenuAutoOffHuman+  , settingsMenuHuman, challengeMenuHuman, gameDifficultyIncr+  , gameFishToggle, gameGoodsToggle, gameWolfToggle, gameKeeperToggle+  , gameScenarioIncr+    -- * Global commands that never take time+  , gameExitWithHuman, ExitStrategy(..), gameDropHuman, gameExitHuman+  , gameSaveHuman, doctrineHuman, automateHuman, automateToggleHuman+  , automateBackHuman+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , areaToRectangles, meleeAid, displaceAid, moveSearchAlter, alterCommon+  , goToXhair, goToXhairExplorationMode, goToXhairGoTo+  , multiActorGoTo, moveOrSelectItem, selectItemsToMove, moveItems+  , projectItem, applyItem, alterTileAtPos, verifyAlters, processTileActions+  , verifyEscape, verifyToolEffect, closeTileAtPos, msgAddDone, pickPoint+  , generateMenu+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Char as Char+import           Data.Either+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import           Data.Version+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Content.Input+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.HandleHumanLocalM+import           Game.LambdaHack.Client.UI.HumanCmd+import           Game.LambdaHack.Client.UI.InventoryM+import           Game.LambdaHack.Client.UI.ItemDescription+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.KeyBindings+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Client.UI.RunM+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.FactionKind as FK+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.ModeKind as MK+import           Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs+import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal++-- * ByArea++-- | Pick command depending on area the mouse pointer is in.+-- The first matching area is chosen. If none match, only interrupt.+byAreaHuman :: MonadClientUI m+            => (K.KM -> HumanCmd -> m (Either MError ReqUI))+            -> [(CmdArea, HumanCmd)]+            -> m (Either MError ReqUI)+byAreaHuman cmdSemInCxtOfKM l = do+  CCUI{coinput=InputContent{brevMap}} <- getsSession sccui+  pUI <- getsSession spointer+  let PointSquare px py = uiToSquare pUI+      p = Point {..}  -- abuse of convention: @Point@, not @PointSquare@ used+                      -- for the whole UI screen in square font coordinates+      pointerInArea a = do+        rs <- areaToRectangles a+        return $! any (`inside` p) $ catMaybes rs+  cmds <- filterM (pointerInArea . fst) l+  case cmds of+    [] -> do+      stopPlayBack+      return $ Left Nothing+    (_, cmd) : _ -> do+      let kmFound = case M.lookup cmd brevMap of+            Just (km : _) -> km+            _ -> K.escKM+      cmdSemInCxtOfKM kmFound cmd++-- Many values here are shared with "Game.LambdaHack.Client.UI.DrawM".+areaToRectangles :: MonadClientUI m => CmdArea -> m [Maybe Area]+areaToRectangles ca = map toArea <$> do+ CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+ case ca of+  CaMessage -> return [(0, 0, rwidth - 1, 0)]+  CaMapLeader -> do  -- takes preference over @CaMapParty@ and @CaMap@+    mleader <- getsClient sleader+    case mleader of+      Nothing -> return []+      Just leader -> do+        b <- getsState $ getActorBody leader+        let PointSquare x y = mapToSquare $ bpos b+        return [(x, y, x, y)]+  CaMapParty -> do  -- takes preference over @CaMap@+    lidV <- viewedLevelUI+    side <- getsClient sside+    ours <- getsState $ filter (not . bproj) . map snd+                        . actorAssocs (== side) lidV+    let rectFromB p = let PointSquare x y = mapToSquare p+                      in (x, y, x, y)+    return $! map (rectFromB . bpos) ours+  CaMap ->+    let PointSquare xo yo = mapToSquare originPoint+        PointSquare xe ye = mapToSquare $ Point (rwidth - 1) (rheight - 4)+    in return [(xo, yo, xe, ye)]+  CaLevelNumber -> let y = rheight - 2+                   in return [(0, y, 1, y)]+  CaArenaName -> let y = rheight - 2+                     x = (rwidth - 1) `div` 2 - 11+                 in return [(3, y, x, y)]+  CaPercentSeen -> let y = rheight - 2+                       x = (rwidth - 1) `div` 2+                   in return [(x - 9, y, x, y)]+  CaXhairDesc -> let y = rheight - 2+                     x = (rwidth - 1) `div` 2 + 2+                 in return [(x, y, rwidth - 1, y)]+  CaSelected -> let y = rheight - 1+                    x = (rwidth - 1) `div` 2+                in return [(0, y, x - 24, y)]+  CaCalmGauge -> let y = rheight - 1+                     x = (rwidth - 1) `div` 2+                 in return [(x - 22, y, x - 18, y)]+  CaCalmValue -> let y = rheight - 1+                     x = (rwidth - 1) `div` 2+                 in return [(x - 17, y, x - 11, y)]+  CaHPGauge -> let y = rheight - 1+                   x = (rwidth - 1) `div` 2+               in return [(x - 9, y, x - 6, y)]+  CaHPValue -> let y = rheight - 1+                   x = (rwidth - 1) `div` 2+               in return [(x - 6, y, x, y)]+  CaLeaderDesc -> let y = rheight - 1+                      x = (rwidth - 1) `div` 2 + 2+                  in return [(x, y, rwidth - 1, y)]++-- * ByAimMode++byAimModeHuman :: MonadClientUI m+               => m (Either MError ReqUI) -> m (Either MError ReqUI)+               -> m (Either MError ReqUI)+byAimModeHuman cmdNotAimingM cmdAimingM = do+  aimMode <- getsSession saimMode+  if isNothing aimMode then cmdNotAimingM else cmdAimingM++-- * ComposeIfLocal++composeIfLocalHuman :: MonadClientUI m+                    => m (Either MError ReqUI) -> m (Either MError ReqUI)+                    -> m (Either MError ReqUI)+composeIfLocalHuman c1 c2 = do+  slideOrCmd1 <- c1+  case slideOrCmd1 of+    Left merr1 -> do+      slideOrCmd2 <- c2+      case slideOrCmd2 of+        Left merr2 -> return $ Left $ mergeMError merr1 merr2+        _ -> return slideOrCmd2+    _ -> return slideOrCmd1++-- * ComposeUnlessError++composeUnlessErrorHuman :: MonadClientUI m+                        => m (Either MError ReqUI) -> m (Either MError ReqUI)+                        -> m (Either MError ReqUI)+composeUnlessErrorHuman c1 c2 = do+  slideOrCmd1 <- c1+  case slideOrCmd1 of+    Left Nothing -> c2+    _ -> return slideOrCmd1++-- * Compose2ndLocal++compose2ndLocalHuman :: MonadClientUI m+                     => m (Either MError ReqUI) -> m (Either MError ReqUI)+                     -> m (Either MError ReqUI)+compose2ndLocalHuman c1 c2 = do+  slideOrCmd1 <- c1+  case slideOrCmd1 of+    Left merr1 -> do+      slideOrCmd2 <- c2+      case slideOrCmd2 of+        Left merr2 -> return $ Left $ mergeMError merr1 merr2+        _ -> return slideOrCmd1  -- ignore second request, keep effect+    req -> do+      void c2  -- ignore second request, keep effect+      return req++-- * LoopOnNothing++loopOnNothingHuman :: MonadClientUI m+                   => m (Either MError ReqUI)+                   -> m (Either MError ReqUI)+loopOnNothingHuman cmd = do+  res <- cmd+  case res of+    Left Nothing -> loopOnNothingHuman cmd+    _ -> return res++-- * ExecuteIfClear++executeIfClearHuman :: MonadClientUI m+                    => m (Either MError ReqUI)+                    -> m (Either MError ReqUI)+executeIfClearHuman c1 = do+  sreportNull <- getsSession sreportNull+  sreqDelay <- getsSession sreqDelay+  -- When server query delay is handled, don't complicate things by clearing+  -- screen instead of running the command.+  if sreportNull || sreqDelay == ReqDelayHandled+  then c1+  else return $ Left Nothing++-- * Wait++-- | Leader waits a turn (and blocks, etc.).+waitHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)+waitHuman leader = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  if Ability.getSk Ability.SkWait actorCurAndMaxSk > 0 then do+    modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}+    return $ Right ReqWait+  else failSer WaitUnskilled++-- * Wait10++-- | Leader waits a 1/10th of a turn (and doesn't block, etc.).+waitHuman10 :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)+waitHuman10 leader = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  if Ability.getSk Ability.SkWait actorCurAndMaxSk >= 4 then do+    modifySession $ \sess -> sess {swaitTimes = abs (swaitTimes sess) + 1}+    return $ Right ReqWait10+  else failSer WaitUnskilled++-- * Yell++-- | Leader yells or yawns, if sleeping.+yellHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)+yellHuman leader = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  if Ability.getSk Ability.SkWait actorCurAndMaxSk > 0+     -- If waiting drained and really, potentially, no other possible action,+     -- still allow yelling.+     || Ability.getSk Ability.SkMove actorCurAndMaxSk <= 0+     || Ability.getSk Ability.SkDisplace actorCurAndMaxSk <= 0+     || Ability.getSk Ability.SkMelee actorCurAndMaxSk <= 0+  then return $ Right ReqYell+  else failSer WaitUnskilled++-- * MoveDir and RunDir++moveRunHuman :: (MonadClient m, MonadClientUI m)+             => ActorId -> Bool -> Bool -> Bool -> Bool -> Vector+             -> m (FailOrCmd RequestTimed)+moveRunHuman leader initialStep finalGoal run runAhead dir = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  arena <- getArenaUI+  sb <- getsState $ getActorBody leader+  fact <- getsState $ (EM.! bfid sb) . sfactionD+  -- Start running in the given direction. The first turn of running+  -- succeeds much more often than subsequent turns, because we ignore+  -- most of the disturbances, since the player is mostly aware of them+  -- and still explicitly requests a run, knowing how it behaves.+  sel <- getsSession sselected+  let runMembers = if runAhead || noRunWithMulti fact+                   then [leader]+                   else ES.elems (ES.delete leader sel) ++ [leader]+      runParams = RunParams { runLeader = leader+                            , runMembers+                            , runInitial = True+                            , runStopMsg = Nothing+                            , runWaiting = 0 }+      initRunning = when (initialStep && run) $ do+        modifySession $ \sess ->+          sess {srunning = Just runParams}+        when runAhead $ macroHuman macroRun25+  -- When running, the invisible actor is hit (not displaced!),+  -- so that running in the presence of roving invisible+  -- actors is equivalent to moving (with visible actors+  -- this is not a problem, since runnning stops early enough).+  let tpos = bpos sb `shift` dir+  -- We start by checking actors at the target position,+  -- which gives a partial information (actors can be invisible),+  -- as opposed to accessibility (and items) which are always accurate+  -- (tiles can't be invisible).+  tgts <- getsState $ posToAidAssocs tpos arena+  case tgts of+    [] -> do  -- move or search or alter+      runStopOrCmd <- moveSearchAlter leader run dir+      case runStopOrCmd of+        Left stopMsg -> return $ Left stopMsg+        Right runCmd -> do+          -- Don't check @initialStep@ and @finalGoal@+          -- and don't stop going to target: door opening is mundane enough.+          initRunning+          return $ Right runCmd+    [(target, _)] | run+                    && initialStep+                    && Ability.getSk Ability.SkDisplace actorCurAndMaxSk > 0 ->+      -- No @stopPlayBack@: initial displace is benign enough.+      -- Displacing requires accessibility, but it's checked later on.+      displaceAid leader target+    _ : _ : _ | run+                && initialStep+                && Ability.getSk Ability.SkDisplace actorCurAndMaxSk > 0 ->+      failSer DisplaceMultiple+    (target, tb) : _ | not run+                       && initialStep && finalGoal+                       && bfid tb == bfid sb && not (bproj tb) -> do+      stopPlayBack  -- don't ever auto-repeat leader choice+      -- We always see actors from our own faction.+      -- Select one of adjacent actors by bumping into him. Takes no time.+      success <- pickLeader True target+      let !_A = assert (success `blame` "bump self"+                                `swith` (leader, target, tb)) ()+      failWith "the pointman switched by bumping"+    (target, tb) : _ | not run+                       && initialStep && finalGoal+                       && (bfid tb /= bfid sb || bproj tb) -> do+      stopPlayBack  -- don't ever auto-repeat melee+      if Ability.getSk Ability.SkMelee actorCurAndMaxSk > 0+      then -- No problem if there are many projectiles at the spot. We just+           -- attack the first one.+           meleeAid leader target+      else failSer MeleeUnskilled+    _ : _ -> failWith "actor in the way"++-- | Actor attacks an enemy actor or his own projectile.+meleeAid :: (MonadClient m, MonadClientUI m)+         => ActorId -> ActorId -> m (FailOrCmd RequestTimed)+meleeAid leader target = do+  side <- getsClient sside+  tb <- getsState $ getActorBody target+  sfact <- getsState $ (EM.! side) . sfactionD+  mel <- pickWeaponClient leader target+  case mel of+    Nothing -> failWith "nothing to melee with"+    Just wp -> do+      let returnCmd = do+            -- Set personal target to enemy, so that AI, if it takes over+            -- the actor, is likely to continue the fight even if the foe flees.+            modifyClient $ updateTarget leader $ const $ Just $ TEnemy target+            -- Also set xhair to see the foe's HP, because it's automatically+            -- set to any new spotted actor, so it needs to be reset+            -- and also it's not useful as permanent ranged target anyway.+            modifySession $ \sess -> sess {sxhair = Just $ TEnemy target}+            return $ Right wp+          res | bproj tb || isFoe side sfact (bfid tb) = returnCmd+              | isFriend side sfact (bfid tb) = do+                let !_A = assert (side /= bfid tb) ()+                go1 <- displayYesNo ColorBW+                         "You are bound by an alliance. Really attack?"+                if not go1 then failWith "attack canceled" else returnCmd+              | otherwise = do+                go2 <- displayYesNo ColorBW+                         "This attack will start a war. Are you sure?"+                if not go2 then failWith "attack canceled" else returnCmd+      res+  -- Seeing the actor prevents altering a tile under it, but that+  -- does not limit the player, he just doesn't waste a turn+  -- on a failed altering.++-- | Actor swaps position with another.+displaceAid :: MonadClientUI m+            => ActorId -> ActorId -> m (FailOrCmd RequestTimed)+displaceAid leader target = do+  COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody leader+  tb <- getsState $ getActorBody target+  tfact <- getsState $ (EM.! bfid tb) . sfactionD+  actorMaxSk <- getsState $ getActorMaxSkills target+  dEnemy <- getsState $ dispEnemy leader target actorMaxSk+  let immobile = Ability.getSk Ability.SkMove actorMaxSk <= 0+      tpos = bpos tb+      adj = checkAdjacent sb tb+      atWar = isFoe (bfid tb) tfact (bfid sb)+  if | not adj -> failSer DisplaceDistant+     | not (bproj tb) && atWar+       && actorDying tb ->  -- checked separately for a better message+       failSer DisplaceDying+     | not (bproj tb) && atWar+       && actorWaits tb ->  -- checked separately for a better message+       failSer DisplaceBraced+     | not (bproj tb) && atWar+       && immobile ->  -- checked separately for a better message+       failSer DisplaceImmobile+     | not dEnemy && atWar ->+       failSer DisplaceSupported+     | otherwise -> do+       let lid = blid sb+       lvl <- getLevel lid+       -- Displacing requires full access.+       if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then+         case posToAidsLvl tpos lvl of+           [] -> error $ "" `showFailure` (leader, sb, target, tb)+           [_] -> return $ Right $ ReqDisplace target+           _ -> failSer DisplaceMultiple+       else failSer DisplaceAccess++-- | Leader moves or searches or alters. No visible actor at the position.+moveSearchAlter :: MonadClientUI m+                => ActorId -> Bool -> Vector -> m (FailOrCmd RequestTimed)+moveSearchAlter leader run dir = do+  COps{coTileSpeedup} <- getsState scops+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  sb <- getsState $ getActorBody leader+  let moveSkill = Ability.getSk Ability.SkMove actorCurAndMaxSk+      spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+  alterable <- getsState $ tileAlterable (blid sb) tpos+  lvl <- getLevel $ blid sb+  let t = lvl `at` tpos+  runStopOrCmd <-+    if Tile.isWalkable coTileSpeedup t then  -- Movement requires full access.+      if | moveSkill > 0 ->+             -- A potential invisible actor is hit. War started without asking.+             return $ Right $ ReqMove dir+         | bwatch sb == WSleep -> failSer MoveUnskilledAsleep+         | otherwise -> failSer MoveUnskilled+    else do  -- Not walkable, so search and/or alter the tile.+      let sxhair = Just $ TPoint TUnknown (blid sb) tpos+      -- Point xhair to see details with `~`.+      setXHairFromGUI sxhair+      if run then do+        -- Explicit request to examine the terrain.+        blurb <- lookAtPosition tpos (blid sb)+        mapM_ (uncurry msgAdd) blurb+        failWith $ "the terrain is" <+>+          if | Tile.isModifiable coTileSpeedup t -> "potentially modifiable"+             | alterable -> "potentially triggerable"+             | otherwise -> "completely inert"+      else alterCommon leader True tpos+  return $! runStopOrCmd++alterCommon :: MonadClientUI m+            => ActorId -> Bool -> Point -> m (FailOrCmd RequestTimed)+alterCommon leader bumping tpos = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  cops@COps{cotile, coTileSpeedup} <- getsState scops+  side <- getsClient sside+  factionD <- getsState sfactionD+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  sb <- getsState $ getActorBody leader+  let alterSkill = Ability.getSk Ability.SkAlter actorCurAndMaxSk+      spos = bpos sb+  alterable <- getsState $ tileAlterable (blid sb) tpos+  lvl <- getLevel $ blid sb+  localTime <- getsState $ getLocalTime (blid sb)+  embeds <- getsState $ getEmbedBag (blid sb) tpos+  itemToF <- getsState $ flip itemToFull+  getKind <- getsState $ flip getIidKind+  let t = lvl `at` tpos+      underFeet = tpos == spos  -- if enter and alter, be more permissive+      modificationFailureHint = msgAdd MsgTutorialHint "Some doors can be opened, stairs unbarred, treasures recovered, only if you find tools that increase your terrain modification ability and act as keys to the puzzle. To gather clues about the keys, listen to what's around you, examine items, inspect terrain, trigger, bump and harass. Once you uncover a likely tool, wield it, return and try to break through again."+  if | not alterable -> do+         let name = MU.Text $ TK.tname $ okind cotile t+             itemLook (iid, kit@(k, _)) =+               let itemFull = itemToF iid+               in partItemWsShort rwidth side factionD k localTime itemFull kit+             embedKindList =+               map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds)+             ilooks = map itemLook $ sortEmbeds cops t embedKindList+         failWith $ makePhrase $+           ["there is no way to activate or modify", MU.AW name]+           ++ if EM.null embeds+              then []+              else ["with", MU.WWandW ilooks]+           -- misclick? related to AlterNothing but no searching possible;+           -- this also rules out activating embeds that only cause+           -- raw damage, with no chance of altering the tile+     | Tile.isSuspect coTileSpeedup t+       && not underFeet+       && alterSkill <= 1 -> do+         modificationFailureHint+         failSer AlterUnskilled+     | not (Tile.isSuspect coTileSpeedup t)+       && not underFeet+       && alterSkill < Tile.alterMinSkill coTileSpeedup t -> do+         -- Rather rare (requires high skill), so describe the tile.+         blurb <- lookAtPosition tpos (blid sb)+         mapM_ (uncurry msgAdd) blurb+         modificationFailureHint+         failSer AlterUnwalked+     | chessDist tpos (bpos sb) > 1 ->+         -- Checked late to give useful info about distant tiles.+         failSer AlterDistant+     | not underFeet+       && (occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl) ->+         -- Don't mislead describing terrain, if other actor is to blame.+         failSer AlterBlockActor+     | otherwise -> do  -- promising+         verAlters <- verifyAlters leader bumping tpos+         case verAlters of+           Right () ->+             if bumping then+               return $ Right $ ReqMove $ vectorToFrom tpos spos+             else do+               msgAddDone False leader tpos "modify"+               return $ Right $ ReqAlter tpos+           Left err -> return $ Left err+         -- Even when bumping, we don't use ReqMove, because we don't want+         -- to hit invisible actors, e.g., hidden in a wall.+         -- If server performed an attack for free+         -- on the invisible actor anyway, the player (or AI)+         -- would be tempted to repeatedly hit random walls+         -- in hopes of killing a monster residing within.+         -- If the action had a cost, misclicks would incur the cost, too.+         -- Right now the player may repeatedly alter tiles trying to learn+         -- about invisible pass-wall actors, but when an actor detected,+         -- it costs a turn and does not harm the invisible actors,+         -- so it's not so tempting.++-- * RunOnceAhead++runOnceAheadHuman :: MonadClientUI m+                  => ActorId -> m (Either MError RequestTimed)+runOnceAheadHuman leader = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  keyPressed <- anyKeyPressed+  srunning <- getsSession srunning+  -- When running, stop if disturbed. If not running, stop at once.+  case srunning of+    Nothing -> do+      msgAdd MsgRunStopReason "run stop: nothing to do"+      return $ Left Nothing+    Just RunParams{runMembers}+      | noRunWithMulti fact && runMembers /= [leader] -> do+      msgAdd MsgRunStopReason "run stop: automatic pointman change"+      return $ Left Nothing+    Just _runParams | keyPressed -> do+      discardPressedKey+      msgAdd MsgRunStopReason "run stop: key pressed"+      weaveJust <$> failWith "interrupted"+    Just runParams -> do+      arena <- getArenaUI+      runOutcome <- continueRun arena runParams+      case runOutcome of+        Left stopMsg -> do+          msgAdd MsgRunStopReason ("run stop:" <+> stopMsg)+          return $ Left Nothing+        Right runCmd ->+          return $ Right runCmd++-- * MoveOnceToXhair++moveOnceToXhairHuman :: (MonadClient m, MonadClientUI m)+                     => ActorId -> m (FailOrCmd RequestTimed)+moveOnceToXhairHuman leader = goToXhair leader True False++goToXhair :: (MonadClient m, MonadClientUI m)+          => ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)+goToXhair leader initialStep run = do+  aimMode <- getsSession saimMode+  -- Movement is legal only outside aiming mode.+  if isJust aimMode+  then failWith "cannot move in aiming mode"+  else goToXhairExplorationMode leader initialStep run++goToXhairExplorationMode :: (MonadClient m, MonadClientUI m)+                         => ActorId -> Bool -> Bool+                         -> m (FailOrCmd RequestTimed)+goToXhairExplorationMode leader initialStep run = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  sb <- getsState $ getActorBody leader+  let moveSkill = Ability.getSk Ability.SkMove actorCurAndMaxSk+  -- If skill is too low, no path in @Bfs@ is going to be found,+  -- but we check the skill (and sleep) to give a more accurate message.+  if | moveSkill > 0 -> do+       xhair <- getsSession sxhair+       xhairGoTo <- getsSession sxhairGoTo+       mfail <-+         if isJust xhairGoTo && xhairGoTo /= xhair+         then failWith "crosshair position changed"+         else do+           when (isNothing xhairGoTo) $  -- set it up for next steps+             modifySession $ \sess -> sess {sxhairGoTo = xhair}+           goToXhairGoTo leader initialStep run+       when (isLeft mfail) $+         modifySession $ \sess -> sess {sxhairGoTo = Nothing}+       return mfail+     | bwatch sb == WSleep -> failSer MoveUnskilledAsleep+     | otherwise -> failSer MoveUnskilled++goToXhairGoTo :: (MonadClient m, MonadClientUI m)+              => ActorId -> Bool -> Bool -> m (FailOrCmd RequestTimed)+goToXhairGoTo leader initialStep run = do+  b <- getsState $ getActorBody leader+  mxhairPos <- mxhairToPos+  case mxhairPos of+    Nothing -> failWith "crosshair position invalid"+    Just c -> do+      running <- getsSession srunning+      case running of+        -- Don't use running params from previous run or goto-xhair.+        Just paramOld | not initialStep -> do+          arena <- getArenaUI+          runOutcome <- multiActorGoTo arena c paramOld+          case runOutcome of+            Left stopMsg -> return $ Left stopMsg+            Right (finalGoal, dir) ->+              moveRunHuman leader initialStep finalGoal run False dir+        _ | c == bpos b -> failWith "position reached"+        _ -> do+          let !_A = assert (initialStep || not run) ()+          (bfs, mpath) <- getCacheBfsAndPath leader c+          xhairMoused <- getsSession sxhairMoused+          case mpath of+            _ | xhairMoused && isNothing (accessBfs bfs c) ->+              failWith+                "no route to crosshair (press again to go there anyway)"+            _ | initialStep && adjacent (bpos b) c -> do+              let dir = towards (bpos b) c+              moveRunHuman leader initialStep True run False dir+            Nothing -> failWith "no route to crosshair"+            Just AndPath{pathList=[]} -> failWith "almost there"+            Just AndPath{pathList = p1 : _} -> do+              let finalGoal = p1 == c+                  dir = towards (bpos b) p1+              moveRunHuman leader initialStep finalGoal run False dir++multiActorGoTo :: (MonadClient m, MonadClientUI m)+               => LevelId -> Point -> RunParams -> m (FailOrCmd (Bool, Vector))+multiActorGoTo arena c paramOld =+  case paramOld of+    RunParams{runMembers = []} -> failWith "selected actors no longer there"+    RunParams{runMembers = r : rs, runWaiting} -> do+      onLevel <- getsState $ memActor r arena+      b <- getsState $ getActorBody r+      mxhairPos <- mxhairToPos+      if not onLevel || mxhairPos == Just (bpos b) then do+        let paramNew = paramOld {runMembers = rs}+        multiActorGoTo arena c paramNew+      else do+        sL <- getState+        modifyClient $ updateLeader r sL+        let runMembersNew = rs ++ [r]+            paramNew = paramOld { runMembers = runMembersNew+                                , runWaiting = 0}+        (bfs, mpath) <- getCacheBfsAndPath r c+        xhairMoused <- getsSession sxhairMoused+        case mpath of+          _ | xhairMoused && isNothing (accessBfs bfs c) ->+            failWith "no route to crosshair (press again to go there anyway)"+          Nothing -> failWith "no route to crosshair"+          Just AndPath{pathList=[]} -> failWith "almost there"+          Just AndPath{pathList = p1 : _} -> do+            let finalGoal = p1 == c+                dir = towards (bpos b) p1+            tgts <- getsState $ posToAids p1 arena+            case tgts of+              [] -> do+                modifySession $ \sess -> sess {srunning = Just paramNew}+                return $ Right (finalGoal, dir)+              [target] | target `elem` rs || runWaiting <= length rs ->+                -- Let r wait until all others move. Mark it in runWaiting+                -- to avoid cycles. When all wait for each other, fail.+                multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}+              _ ->+                failWith "collective running finished"  -- usually OK++-- * RunOnceToXhair++runOnceToXhairHuman :: (MonadClient m, MonadClientUI m)+                    => ActorId -> m (FailOrCmd RequestTimed)+runOnceToXhairHuman leader = goToXhair leader True True++-- * ContinueToXhair++continueToXhairHuman :: (MonadClient m, MonadClientUI m)+                     => ActorId -> m (FailOrCmd RequestTimed)+continueToXhairHuman leader = goToXhair leader False False{-irrelevant-}++-- * MoveItem++moveItemHuman :: forall m. MonadClientUI m+              => ActorId -> [CStore] -> CStore -> Maybe Text -> Bool+              -> m (FailOrCmd RequestTimed)+moveItemHuman leader stores destCStore mverb auto = do+  let !_A = assert (destCStore `notElem` stores) ()+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  if Ability.getSk Ability.SkMoveItem actorCurAndMaxSk > 0+  then moveOrSelectItem leader stores destCStore mverb auto+  else failSer MoveItemUnskilled++-- This cannot be structured as projecting or applying, with @ByItemMode@+-- and @ChooseItemToMove@, because at least in case of grabbing items,+-- more than one item is chosen, which doesn't fit @sitemSel@. Separating+-- grabbing of multiple items as a distinct command is too high a price.+moveOrSelectItem :: forall m. MonadClientUI m+                 => ActorId -> [CStore] -> CStore -> Maybe Text -> Bool+                 -> m (FailOrCmd RequestTimed)+moveOrSelectItem leader storesRaw destCStore mverb auto = do+  b <- getsState $ getActorBody leader+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+  let calmE = calmEnough b actorCurAndMaxSk+      overStash = mstash == Just (blid b, bpos b)+      stores = case storesRaw of+        CEqp : rest@(_ : _) | not calmE -> rest ++ [CEqp]+        CGround : rest@(_ : _) | overStash -> rest ++ [CGround]+        _ -> storesRaw+  itemSel <- getsSession sitemSel+  modifySession $ \sess -> sess {sitemSel = Nothing}  -- prevent surprise+  case itemSel of+    _ | stores == [CGround] && overStash ->+      failWith "you can't loot items from your own stash"+    Just (_, fromCStore@CEqp, _) | fromCStore /= destCStore+                                   && fromCStore `elem` stores+                                   && not calmE ->+      failWith "neither the selected item nor any other can be unequipped"+    Just (_, fromCStore@CGround, _) | fromCStore /= destCStore+                                      && fromCStore `elem` stores+                                      && overStash ->+      failWith "you vainly paw through your own hoard"+    Just (iid, fromCStore, _) | fromCStore /= destCStore+                                && fromCStore `elem` stores -> do+      bag <- getsState $ getBodyStoreBag b fromCStore+      case iid `EM.lookup` bag of+        Nothing ->  -- the case of old selection or selection from another actor+          moveOrSelectItem leader stores destCStore mverb auto+        Just (k, it) -> assert (k > 0) $ do+          let eqpFree = eqpFreeN b+              kToPick | destCStore == CEqp = min eqpFree k+                      | otherwise = k+          if | destCStore == CEqp && not calmE -> failSer ItemNotCalm+             | destCStore == CGround && overStash -> failSer ItemOverStash+             | kToPick == 0 -> failWith "no more items can be equipped"+             | otherwise -> do+               socK <- pickNumber (not auto) kToPick+               case socK of+                 Left Nothing ->+                   moveOrSelectItem leader stores destCStore mverb auto+                 Left (Just err) -> return $ Left err+                 Right kChosen ->+                   let is = (fromCStore, [(iid, (kChosen, take kChosen it))])+                   in Right <$> moveItems leader stores is destCStore+    _ -> do+      mis <- selectItemsToMove leader stores destCStore mverb auto+      case mis of+        Left err -> return $ Left err+        Right (fromCStore, [(iid, _)]) | stores /= [CGround] -> do+          modifySession $ \sess ->+            sess {sitemSel = Just (iid, fromCStore, False)}+          moveOrSelectItem leader stores destCStore mverb auto+        Right is@(fromCStore, _) ->+          if | fromCStore == CEqp && not calmE -> failSer ItemNotCalm+             | fromCStore == CGround && overStash -> failSer ItemOverStash+             | otherwise -> Right <$> moveItems leader stores is destCStore++selectItemsToMove :: forall m. MonadClientUI m+                  => ActorId -> [CStore] -> CStore -> Maybe Text -> Bool+                  -> m (FailOrCmd (CStore, [(ItemId, ItemQuant)]))+selectItemsToMove leader stores destCStore mverb auto = do+  let verb = fromMaybe (verbCStore destCStore) mverb+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  b <- getsState $ getActorBody leader+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+  lastItemMove <- getsSession slastItemMove+  -- This calmE is outdated when one of the items increases max Calm+  -- (e.g., in pickup, which handles many items at once), but this is OK,+  -- the server accepts item movement based on calm at the start, not end+  -- or in the middle.+  -- The calmE is inaccurate also if an item not IDed, but that's intended+  -- and the server will ignore and warn (and content may avoid that,+  -- e.g., making all rings identified)+  let calmE = calmEnough b actorCurAndMaxSk+      overStash = mstash == Just (blid b, bpos b)+  if | destCStore == CEqp && not calmE -> failSer ItemNotCalm+     | destCStore == CGround && overStash -> failSer ItemOverStash+     | destCStore == CEqp && eqpOverfull b 1 -> failSer EqpOverfull+     | otherwise -> do+       let storesLast = case lastItemMove of+             Just (lastFrom, lastDest) | lastDest == destCStore+                                         && lastFrom `elem` stores ->+               lastFrom : delete lastFrom stores+             _ -> stores+           prompt = "What to"+           promptEqp = "What consumable to"+           eqpItemsN body =+             let n = sum $ map fst $ EM.elems $ beqp body+             in "(" <> makePhrase [MU.CarWs n "item"]+           ppItemDialogBody body actorSk cCur = case cCur of+             MStore CEqp | not $ calmEnough body actorSk ->+               "distractedly paw at" <+> ppItemDialogModeIn cCur+             MStore CGround | mstash == Just (blid body, bpos body) ->+               "greedily fondle" <+> ppItemDialogModeIn cCur+             _ -> case destCStore of+               CEqp | not $ calmEnough body actorSk ->+                 "distractedly attempt to" <+> verb+                 <+> ppItemDialogModeFrom cCur+               CEqp | eqpOverfull body 1 ->+                 "attempt to fit into equipment" <+> ppItemDialogModeFrom cCur+               CGround | mstash == Just (blid body, bpos body) ->+                 "greedily attempt to" <+> verb <+> ppItemDialogModeFrom cCur+               CEqp -> verb+                       <+> eqpItemsN body <+> "so far)"+                       <+> ppItemDialogModeFrom cCur+               _ -> verb <+> ppItemDialogModeFrom cCur+                    <+> if cCur == MStore CEqp+                        then eqpItemsN body <+> "now)"+                        else ""+           (promptGeneric, psuit) =+             -- We prune item list only for eqp, because other stores don't have+             -- so clear cut heuristics. So when picking up a stash, either grab+             -- it to auto-store things, or equip first using the pruning+             -- and then stash the rest selectively or en masse.+             if destCStore == CEqp+             then (promptEqp, return $ SuitsSomething $ \_ itemFull _kit ->+                    IA.goesIntoEqp $ aspectRecordFull itemFull)+             else (prompt, return SuitsEverything)+       ggi <-+         getFull leader psuit+                 (\body _ actorSk cCur _ ->+                    prompt <+> ppItemDialogBody body actorSk cCur)+                 (\body _ actorSk cCur _ ->+                    promptGeneric <+> ppItemDialogBody body actorSk cCur)+                 storesLast (not auto) True+       case ggi of+         Right (fromCStore, l) -> do+           modifySession $ \sess ->+             sess {slastItemMove = Just (fromCStore, destCStore)}+           return $ Right (fromCStore, l)+         Left err -> failWith err++moveItems :: forall m. MonadClientUI m+          => ActorId -> [CStore] -> (CStore, [(ItemId, ItemQuant)]) -> CStore+          -> m RequestTimed+moveItems leader stores (fromCStore, l) destCStore = do+  let !_A = assert (fromCStore /= destCStore && fromCStore `elem` stores) ()+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  b <- getsState $ getActorBody leader+  discoBenefit <- getsClient sdiscoBenefit+  let calmE = calmEnough b actorCurAndMaxSk+      ret4 :: [(ItemId, ItemQuant)] -> Int -> m [(ItemId, Int, CStore, CStore)]+      ret4 [] _ = return []+      ret4 ((iid, (k, _)) : rest) oldN = do+        let !_A = assert (k > 0) ()+            retRec toCStore = do+              let n = oldN + if toCStore == CEqp then k else 0+              l4 <- ret4 rest n+              return $ (iid, k, fromCStore, toCStore) : l4+        if stores == [CGround] && destCStore == CStash  -- normal pickup+        then -- @CStash@ is the implicit default; refine:+             if | not $ benInEqp $ discoBenefit EM.! iid -> retRec CStash+                | eqpOverfull b (oldN + 1) -> do+                  -- Action goes through, but changed, so keep in history.+                  msgAdd MsgActionWarning $+                    "Warning:" <+> showReqFailure EqpOverfull <> "."+                  retRec CStash+                | eqpOverfull b (oldN + k) -> do+                  -- If this stack doesn't fit, we don't equip any part of it,+                  -- but we may equip a smaller stack later of other items+                  -- in the same pickup.+                  msgAdd MsgActionWarning $+                    "Warning:" <+> showReqFailure EqpStackFull <> "."+                  retRec CStash+                | not calmE -> do+                  msgAdd MsgActionWarning $+                    "Warning:" <+> showReqFailure ItemNotCalm <> "."+                  retRec CStash+                | otherwise ->+                  -- Prefer @CEqp@ if all conditions hold:+                  retRec CEqp+        else case destCStore of  -- player forces store, so @benInEqp@ ignored+          CEqp | eqpOverfull b (oldN + 1) -> do+            -- Action aborted, so different colour and not in history.+            msgAdd MsgPromptItems $+              "Failure:" <+> showReqFailure EqpOverfull <> "."+            -- No recursive call here, we exit item manipulation,+            -- but something is moved or else outer functions would not call us.+            return []+          CEqp | eqpOverfull b (oldN + k) -> do+            msgAdd MsgPromptItems $+              "Failure:" <+> showReqFailure EqpStackFull <> "."+            return []+          _ -> retRec destCStore+  l4 <- ret4 l 0+  if null l4+  then error $ "" `showFailure` (stores, fromCStore, l, destCStore)+  else return $! ReqMoveItems l4++-- * Project++projectHuman :: (MonadClient m, MonadClientUI m)+             => ActorId -> m (FailOrCmd RequestTimed)+projectHuman leader = do+  curChal <- getsClient scurChal+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  if | ckeeper curChal ->+       failSer ProjectFinderKeeper+     | Ability.getSk Ability.SkProject actorCurAndMaxSk <= 0 ->+       -- Detailed are check later.+       failSer ProjectUnskilled+     | otherwise -> do+       itemSel <- getsSession sitemSel+       case itemSel of+         Just (_, COrgan, _) -> failWith "can't fling an organ"+         Just (iid, fromCStore, _) -> do+           b <- getsState $ getActorBody leader+           bag <- getsState $ getBodyStoreBag b fromCStore+           case iid `EM.lookup` bag of+             Nothing -> failWith "no item to fling"+             Just _kit -> do+               itemFull <- getsState $ itemToFull iid+               let i = (fromCStore, (iid, itemFull))+               projectItem leader i+         Nothing -> failWith "no item to fling"++projectItem :: (MonadClient m, MonadClientUI m)+            => ActorId -> (CStore, (ItemId, ItemFull))+            -> m (FailOrCmd RequestTimed)+projectItem leader (fromCStore, (iid, itemFull)) = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  b <- getsState $ getActorBody leader+  let calmE = calmEnough b actorCurAndMaxSk+  if fromCStore == CEqp && not calmE then failSer ItemNotCalm+  else do+    mpsuitReq <- psuitReq leader+    case mpsuitReq of+      Left err -> failWith err+      Right psuitReqFun ->+        case psuitReqFun itemFull of+          Left reqFail -> failSer reqFail+          Right (pos, _) -> do+            Benefit{benFling} <- getsClient $ (EM.! iid) . sdiscoBenefit+            go <- if benFling >= 0+                  then displayYesNo ColorFull+                         "The item may be beneficial. Do you really want to fling it?"+                  else return True+            if go then do+              -- Set personal target to enemy, so that AI, if it takes over+              -- the actor, is likely to continue the fight even if the foe+              -- flees. Similarly if the crosshair points at position, etc.+              sxhair <- getsSession sxhair+              modifyClient $ updateTarget leader (const sxhair)+              -- Project.+              eps <- getsClient seps+              return $ Right $ ReqProject pos eps iid fromCStore+            else do+              modifySession $ \sess -> sess {sitemSel = Nothing}+              failWith "never mind"++-- * Apply++applyHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)+applyHuman leader = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  if Ability.getSk Ability.SkApply+                   actorCurAndMaxSk <= 0 then  -- detailed check later+    failSer ApplyUnskilled+  else do+    itemSel <- getsSession sitemSel+    case itemSel of+      Just (iid, fromCStore, _) -> do+        b <- getsState $ getActorBody leader+        bag <- getsState $ getBodyStoreBag b fromCStore+        case iid `EM.lookup` bag of+          Nothing -> failWith "no item to trigger"+          Just kit -> do+            itemFull <- getsState $ itemToFull iid+            applyItem leader (fromCStore, (iid, (itemFull, kit)))+      Nothing -> failWith "no item to trigger"++applyItem :: MonadClientUI m+          => ActorId -> (CStore, (ItemId, ItemFullKit))+          -> m (FailOrCmd RequestTimed)+applyItem leader (fromCStore, (iid, (itemFull, kit))) = do+  COps{corule} <- getsState scops+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  b <- getsState $ getActorBody leader+  localTime <- getsState $ getLocalTime (blid b)+  let skill = Ability.getSk Ability.SkApply actorCurAndMaxSk+      calmE = calmEnough b actorCurAndMaxSk+      arItem = aspectRecordFull itemFull+  if fromCStore == CEqp && not calmE then failSer ItemNotCalm+  else case permittedApply corule localTime skill calmE (Just fromCStore)+                           itemFull kit of+    Left reqFail -> failSer reqFail+    Right _ -> do+      Benefit{benApply} <- getsClient $ (EM.! iid) . sdiscoBenefit+      go <-+        if | IA.checkFlag Ability.Periodic arItem+             && not (IA.checkFlag Ability.Durable arItem) ->+             -- No warning if item durable, because activation weak,+             -- but price low, due to no destruction.+             displayYesNo ColorFull+                          "Triggering this periodic item may not produce all its effects (check item description) and moreover, because it's not durable, will destroy it. Are you sure?"+           | benApply < 0 ->+             displayYesNo ColorFull+                          "The item appears harmful. Do you really want to trigger it?"+           | otherwise -> return True+      if go+      then return $ Right $ ReqApply iid fromCStore+      else do+        modifySession $ \sess -> sess {sitemSel = Nothing}+        failWith "never mind"++-- * AlterDir++-- | Ask for a direction and alter a tile, if possible.+alterDirHuman :: MonadClientUI m => ActorId -> m (FailOrCmd RequestTimed)+alterDirHuman leader = pickPoint leader "modify" >>= \case+  Just p -> alterTileAtPos leader p+  Nothing -> failWith "never mind"++-- | Try to alter a tile using a feature at the given position.+--+-- We don't check if the tile is interesting, e.g., if any embedded+-- item can be triggered, because the player explicitely requested+-- the action. Consequently, even if all embedded items are recharching,+-- the time will be wasted and the server will describe the failure in detail.+alterTileAtPos :: MonadClientUI m+               => ActorId -> Point -> m (FailOrCmd RequestTimed)+alterTileAtPos leader pos = do+  sb <- getsState $ getActorBody leader+  let sxhair = Just $ TPoint TUnknown (blid sb) pos+  -- Point xhair to see details with `~`.+  setXHairFromGUI sxhair+  alterCommon leader False pos++-- | Verify that the tile can be transformed or any embedded item effect+-- triggered and the player is aware if the effect is dangerous or grave,+-- such as ending the game.+verifyAlters :: forall m. MonadClientUI m+             => ActorId -> Bool -> Point -> m (FailOrCmd ())+verifyAlters leader bumping tpos = do+  COps{cotile, coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody leader+  arItem <- getsState $ aspectRecordFromIid $ btrunk sb+  embeds <- getsState $ getEmbedBag (blid sb) tpos+  lvl <- getLevel $ blid sb+  getKind <- getsState $ flip getIidKind+  let embedKindList =+        if IA.checkFlag Ability.Blast arItem+        then []  -- prevent embeds triggering each other in a loop+        else map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds)+      underFeet = tpos == bpos sb  -- if enter and alter, be more permissive+      blockedByItem = EM.member tpos (lfloor lvl)+      tile = lvl `at` tpos+      feats = TK.tfeature $ okind cotile tile+      tileActions =+        mapMaybe (parseTileAction+                    (bproj sb)+                    (underFeet || blockedByItem)  -- avoids AlterBlockItem+                    embedKindList)+                 feats+  if null tileActions+     && blockedByItem+     && not underFeet+     && Tile.isModifiable coTileSpeedup tile+  then failSer AlterBlockItem+  else processTileActions leader bumping tpos tileActions++processTileActions :: forall m. MonadClientUI m+                   => ActorId -> Bool -> Point -> [TileAction]+                   -> m (FailOrCmd ())+processTileActions leader bumping tpos tas = do+  COps{coTileSpeedup} <- getsState scops+  getKind <- getsState $ flip getIidKind+  sb <- getsState $ getActorBody leader+  lvl <- getLevel $ blid sb+  sar <- getsState $ aspectRecordFromIid $ btrunk sb+  let leaderIsMist = IA.checkFlag Ability.Blast sar+                     && Dice.infDice (IK.idamage $ getKind $ btrunk sb) <= 0+      tileMinSkill = Tile.alterMinSkill coTileSpeedup $ lvl `at` tpos+      processTA :: Maybe Bool -> [TileAction] -> Bool+                -> m (FailOrCmd (Maybe (Bool, Bool)))+      processTA museResult [] bumpFailed = do+        let useResult = fromMaybe False museResult+        -- No warning will be generated if during explicit modification+        -- an embed is activated but there is not enough tools+        -- for a subsequent transformation. This is fine. Bumping would+        -- produce the warning and S-dir also displays the tool info.+        -- We can't rule out the embed is the main feature and the tool+        -- transformation is not important despite following it.+        -- We don't want spam in such a case.+        return $ Right $ if Tile.isSuspect coTileSpeedup (lvl `at` tpos)+                            || useResult && not bumpFailed+                         then Nothing  -- success of some kind+                         else Just (useResult, bumpFailed)  -- not quite+      processTA museResult (ta : rest) bumpFailed = case ta of+        EmbedAction (iid, _) -> do+          -- Embeds are activated in the order in tile definition+          -- and never after the tile is changed.+          -- We assume the item would trigger and we let the player+          -- take the risk of wasted turn to verify the assumption.+          -- If the item recharges, the wasted turns let the player wait.+          let useResult = fromMaybe False museResult+          if | leaderIsMist+               || bproj sb && tileMinSkill > 0 ->  -- local skill check+               processTA (Just useResult) rest bumpFailed+                 -- embed won't fire; try others+             | (not . any IK.isEffEscape) (IK.ieffects $ getKind iid) ->+               processTA (Just True) rest False+                 -- no escape checking needed, effect found;+                 -- also bumpFailed reset, because must have been+                 -- marginal if an embed was following it+             | otherwise -> do+               mfail <- verifyEscape+               case mfail of+                 Left err -> return $ Left err+                 Right () -> processTA (Just True) rest False+                   -- effect found, bumpFailed reset+        ToAction{} ->+          if fromMaybe True museResult+             && not (bproj sb && tileMinSkill > 0)  -- local skill check+          then return $ Right Nothing  -- tile changed, no more activations+          else processTA museResult rest bumpFailed+                 -- failed, but not due to bumping+        WithAction tools0 _ ->+          if not bumping || null tools0 then+            if fromMaybe True museResult then do+              -- UI requested, so this is voluntary, so item loss is fine.+              kitAssG <- getsState $ kitAssocs leader [CGround]+              kitAssE <- getsState $ kitAssocs leader [CEqp]+              let kitAss = listToolsToConsume kitAssG kitAssE+                  grps0 = map (\(x, y) -> (False, x, y)) tools0+                    -- apply if durable+                  (_, iidsToApply, grps) =+                    foldl' subtractIidfromGrps (EM.empty, [], grps0) kitAss+              if null grps then do+                let hasEffectOrDmg (_, (_, ItemFull{itemKind})) =+                      IK.idamage itemKind /= 0+                      || any IK.forApplyEffect (IK.ieffects itemKind)+                mfail <- case filter hasEffectOrDmg iidsToApply of+                  [] -> return $ Right ()+                  (store, (_, itemFull)) : _ ->+                    verifyToolEffect (blid sb) store itemFull+                case mfail of+                  Left err -> return $ Left err+                  Right () -> return $ Right Nothing  -- tile changed, done+              else processTA museResult rest bumpFailed  -- not enough tools+            else processTA museResult rest bumpFailed  -- embeds failed+          else processTA museResult rest True  -- failed due to bumping+  mfail <- processTA Nothing tas False+  case mfail of+    Left err -> return $ Left err+    Right Nothing -> return $ Right ()+    Right (Just (useResult, bumpFailed)) -> do+      let !_A = assert (not useResult || bumpFailed) ()+      blurb <- lookAtPosition tpos (blid sb)+      mapM_ (uncurry msgAdd) blurb+      if bumpFailed then do+        revCmd <- revCmdMap+        let km = revCmd AlterDir+            msg = "bumping is not enough to transform this terrain; modify with the '"+                  <> T.pack (K.showKM km)+                  <> "' command instead"+        if useResult then do+          merr <- failMsg msg+          msgAdd MsgPromptAction $ showFailError $ fromJust merr+          return $ Right ()  -- effect the embed activation, though+        else failWith msg+      else failWith "unable to activate nor modify at this time"+        -- related to, among others, @SfxNoItemsForTile@ on the server++verifyEscape :: MonadClientUI m => m (FailOrCmd ())+verifyEscape = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  if not (FK.fcanEscape $ gkind fact)+  then failWith+         "This is the way out, but where would you go in this alien world?"+           -- exceptionally a full sentence, because a real question+  else do+    (_, total) <- getsState $ calculateTotal side+    dungeonTotal <- getsState sgold+    let prompt | dungeonTotal == 0 =+                 "You finally reached your goal. Really leave now?"+               | total == 0 =+                 "Afraid of the challenge? Leaving so soon and without any treasure? Are you sure?"+               | total < dungeonTotal =+                 "You've finally found the way out, but you didn't gather all valuables rumoured to be laying around. Really leave already?"+               | otherwise =+                 "This is the way out and you collected all treasure there is to find. Really leave now?"+    -- The player can back off, but we never insist,+    -- because possibly the score formula doesn't reward treasure+    -- or he is focused on winning only.+    go <- displayYesNo ColorBW prompt+    if not go+    then failWith "here's your chance"+    else return $ Right ()++verifyToolEffect :: MonadClientUI m+                 => LevelId -> CStore -> ItemFull -> m (FailOrCmd ())+verifyToolEffect lid store itemFull = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  side <- getsClient sside+  localTime <- getsState $ getLocalTime lid+  factionD <- getsState sfactionD+  let (name1, powers) = partItemShort rwidth side factionD localTime+                                      itemFull quantSingle+      objectA = makePhrase [MU.AW name1, powers]+      -- "Potentially", because an unidentified items on the ground can take+      -- precedence (perhaps placed there in order to get identified!).+      prompt = "Do you really want to transform the terrain potentially using"+               <+> objectA <+> ppCStoreIn store+               <+> "that may cause substantial side-effects?"+      objectThe = makePhrase ["the", name1]+  go <- displayYesNo ColorBW prompt+  if not go+  then failWith $ "replace" <+> objectThe <+> "and try again"+         -- question capitalized and ended with a dot, answer neither+  else return $ Right ()++-- * AlterWithPointer++-- | Try to alter a tile using a feature under the pointer.+alterWithPointerHuman :: MonadClientUI m+                      => ActorId -> m (FailOrCmd RequestTimed)+alterWithPointerHuman leader = do+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  pUI <- getsSession spointer+  let p = squareToMap $ uiToSquare pUI+  if insideP (0, 0, rWidthMax - 1, rHeightMax - 1) p+  then alterTileAtPos leader p+  else failWith "never mind"++-- * CloseDir++-- | Close nearby open tile; ask for direction, if there is more than one.+closeDirHuman :: MonadClientUI m+              => ActorId -> m (FailOrCmd RequestTimed)+closeDirHuman leader = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody leader+  lvl <- getLevel $ blid b+  let vPts = vicinityUnsafe $ bpos b+      openPts = filter (Tile.isClosable coTileSpeedup . at lvl) vPts+  case openPts of+    []  -> failSer CloseNothing+    [o] -> closeTileAtPos leader o+    _   -> pickPoint leader "close" >>= \case+      Nothing -> failWith "never mind"+      Just p -> closeTileAtPos leader p++-- | Close tile at given position.+closeTileAtPos :: MonadClientUI m+               => ActorId -> Point -> m (FailOrCmd RequestTimed)+closeTileAtPos leader tpos = do+  COps{coTileSpeedup} <- getsState scops+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  b <- getsState $ getActorBody leader+  alterable <- getsState $ tileAlterable (blid b) tpos+  lvl <- getLevel $ blid b+  let alterSkill = Ability.getSk Ability.SkAlter actorCurAndMaxSk+      t = lvl `at` tpos+      isOpen = Tile.isClosable coTileSpeedup t+      isClosed = Tile.isOpenable coTileSpeedup t+  case (alterable, isClosed, isOpen) of+    (False, _, _) -> failSer CloseNothing+    (True, False, False) -> failSer CloseNonClosable+    (True, True,  False) -> failSer CloseClosed+    (True, True,  True) -> error "TileKind content validation"+    (True, False, True) ->+      if | tpos `chessDist` bpos b > 1+          -> failSer CloseDistant+         | alterSkill <= 1+          -> failSer AlterUnskilled+         | EM.member tpos $ lfloor lvl+          -> failSer AlterBlockItem+         | occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl+          -> failSer AlterBlockActor+         | otherwise+          -> do+             msgAddDone True leader tpos "close"+             return $ Right (ReqAlter tpos)++-- | Adds message with proper names.+msgAddDone :: MonadClientUI m => Bool -> ActorId -> Point -> Text -> m ()+msgAddDone mentionTile leader p verb = do+  COps{cotile} <- getsState scops+  b <- getsState $ getActorBody leader+  lvl <- getLevel $ blid b+  let tname = TK.tname $ okind cotile $ lvl `at` p+      s = case T.words tname of+            [] -> "thing"+            ("open" : xs) -> T.unwords xs+            _ -> tname+      object | mentionTile = "the" <+> s+             | otherwise = ""+      v = p `vectorToFrom` bpos b+      dir | v == Vector 0 0 = "underneath"+          | otherwise = compassText v+  msgAdd MsgActionComplete $ "You" <+> verb <+> object <+> dir <> "."++-- | Prompts user to pick a point.+pickPoint :: MonadClientUI m => ActorId -> Text -> m (Maybe Point)+pickPoint leader verb = do+  b <- getsState $ getActorBody leader+  UIOptions{uVi, uLeftHand} <- getsSession sUIOptions+  let dirKeys = K.dirAllKey uVi uLeftHand+      keys = K.escKM+           : K.leftButtonReleaseKM+           : map (K.KM K.NoModifier) dirKeys+  msgAdd MsgPromptGeneric $ "Where to" <+> verb <> "? [movement key] [pointer]"+  slides <- reportToSlideshow [K.escKM]+  km <- getConfirms ColorFull keys slides+  case K.key km of+    K.LeftButtonRelease -> do+      pUI <- getsSession spointer+      let p = squareToMap $ uiToSquare pUI+      return $ Just p+    _ -> return $ shift (bpos b) <$> K.handleDir dirKeys km++-- * Help++-- | Display command help.+helpHuman :: MonadClientUI m+          => (K.KM -> HumanCmd -> m (Either MError ReqUI))+          -> m (Either MError ReqUI)+helpHuman cmdSemInCxtOfKM = do+  ccui@CCUI{coinput, coscreen=ScreenContent{rwidth, rheight, rintroScreen}}+    <- getsSession sccui+  fontSetup@FontSetup{..} <- getFontSetup+  gameModeId <- getsState sgameModeId+  modeOv <- describeMode True gameModeId+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  let displayTutorialHints = fromMaybe curTutorial overrideTut+      modeH = ( "Press SPACE or PGDN to advance or ESC to see the map again."+              , (modeOv, []) )+      keyH = keyHelp ccui fontSetup+      -- This takes a list of paragraphs and returns a list of screens.+      -- Both paragraph and screen is a list of lines.+      --+      -- This would be faster, but less clear, if paragraphs were stored+      -- reversed in content. Not worth it, until we have huge manuals+      -- or run on weak mobiles. Even then, precomputation during+      -- compilation may be better.+      --+      -- Empty lines may appear at the end of pages, but it's fine,+      -- it means there is a new section on the next page.+      packIntoScreens :: [[String]] -> [[String]] -> Int -> [[String]]+      packIntoScreens [] acc _ = [intercalate [""] (reverse acc)]+      packIntoScreens ([] : ls) [] _  =+        -- Ignore empty paragraphs at the start of screen.+        packIntoScreens ls [] 0+      packIntoScreens (l : ls) [] h = assert (h == 0) $+        -- If a paragraph, even alone, is longer than screen height, it's split.+        if length l <= rheight - 3+        then packIntoScreens ls [l] (length l)+        else let (screen, rest) = splitAt (rheight - 3) l+             in screen : packIntoScreens (rest : ls) [] 0+      packIntoScreens (l : ls) acc h =+        -- The extra @+ 1@ comes from the empty line separating paragraphs,+        -- as added in @intercalate@.+        if length l + 1 + h <= rheight - 3+        then packIntoScreens ls (l : acc) (length l + 1 + h)+        else intercalate [""] (reverse acc) : packIntoScreens (l : ls) [] 0+      manualScreens = packIntoScreens (snd rintroScreen) [] 0+      sideBySide =+        if isSquareFont monoFont+        then \(screen1, screen2) ->  -- single column, two screens+          map offsetOverlay $ filter (not . null) [screen1, screen2]+        else \(screen1, screen2) ->  -- two columns, single screen+          [offsetOverlay screen1+           ++ xtranslateOverlay rwidth (offsetOverlay screen2)]+      listPairs (a : b : rest) = (a, b) : listPairs rest+      listPairs [a] = [(a, [])]+      listPairs [] = []+      -- Each screen begins with an empty line, to separate the header.+      manualOvs = map (EM.singleton monoFont)+                  $ concatMap sideBySide $ listPairs+                  $ map ((emptyAttrLine :) . map stringToAL) manualScreens+      addMnualHeader ov =+        ( "Showing PLAYING.md (best viewed in the browser)."+        , (ov, []) )+      manualH = map addMnualHeader manualOvs+      splitHelp (t, okx) =+        splitOKX fontSetup True rwidth rheight rwidth (textToAS t)+                 [K.spaceKM, K.returnKM, K.escKM] okx+      sli = toSlideshow fontSetup displayTutorialHints+            $ concatMap splitHelp $ modeH : keyH ++ manualH+  -- Thus, the whole help menu corresponds to a single menu of item or lore,+  -- e.g., shared stash menu. This is especially clear when the shared stash+  -- menu contains many pages.+  ekm <- displayChoiceScreen "help" ColorFull True sli+                             [K.spaceKM, K.returnKM, K.escKM]+  case ekm of+    Left km | km `elem` [K.escKM, K.spaceKM] -> return $ Left Nothing+    Left km | km == K.returnKM -> do+      msgAdd MsgPromptGeneric "Press RET when a command help text is selected to invoke the command."+      return $ Left Nothing+    Left km -> case km `M.lookup` bcmdMap coinput of+      Just (_desc, _cats, cmd) -> cmdSemInCxtOfKM km cmd+      Nothing -> weaveJust <$> failWith "never mind"+    Right _slot -> error $ "" `showFailure` ekm++-- * Hint++-- | Display hint or, if already displayed, display help.+hintHuman :: MonadClientUI m+          => (K.KM -> HumanCmd -> m (Either MError ReqUI))+          -> m (Either MError ReqUI)+hintHuman cmdSemInCxtOfKM = do+  sreportNull <- getsSession sreportNull+  if sreportNull then do+    promptMainKeys+    return $ Left Nothing+  else+    helpHuman cmdSemInCxtOfKM++-- * Dashboard++-- | Display the dashboard.+dashboardHuman :: MonadClientUI m+               => (K.KM -> HumanCmd -> m (Either MError ReqUI))+               -> m (Either MError ReqUI)+dashboardHuman cmdSemInCxtOfKM = do+  CCUI{coinput, coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+  fontSetup@FontSetup{..} <- getFontSetup+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  let displayTutorialHints = fromMaybe curTutorial overrideTut+      offsetCol2 = 3+      (ov0, kxs0) = okxsN coinput monoFont propFont offsetCol2 (const False)+                          False CmdDashboard ([], [], []) ([], [])+      al1 = textToAS "Dashboard"+      splitHelp (al, okx) = splitOKX fontSetup False rwidth (rheight - 2) rwidth+                                     al [K.returnKM, K.escKM] okx+      sli = toSlideshow fontSetup displayTutorialHints+            $ splitHelp (al1, (ov0, kxs0))+      extraKeys = [K.returnKM, K.escKM]+  ekm <- displayChoiceScreen "dashboard" ColorFull False sli extraKeys+  case ekm of+    Left km -> case km `M.lookup` bcmdMap coinput of+      _ | km == K.escKM -> weaveJust <$> failWith "never mind"+      _ | km == K.returnKM -> do+        msgAdd MsgPromptGeneric "Press RET when a menu name is selected to browse the menu."+        return $ Left Nothing+      Just (_desc, _cats, cmd) -> cmdSemInCxtOfKM km cmd+      Nothing -> weaveJust <$> failWith "never mind"+    Right _slot -> error $ "" `showFailure` ekm++-- * ItemMenu++itemMenuHuman :: MonadClientUI m+              => ActorId+              -> (K.KM -> HumanCmd -> m (Either MError ReqUI))+              -> m (Either MError ReqUI)+itemMenuHuman leader cmdSemInCxtOfKM = do+  COps{corule} <- getsState scops+  itemSel <- getsSession sitemSel+  fontSetup@FontSetup{..} <- getFontSetup+  case itemSel of+    Just (iid, fromCStore, _) -> do+      side <- getsClient sside+      b <- getsState $ getActorBody leader+      bUI <- getsSession $ getActorUI leader+      bag <- getsState $ getBodyStoreBag b fromCStore+      case iid `EM.lookup` bag of+        Nothing -> weaveJust <$> failWith "no item to open item menu for"+        Just kit -> do+          CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+          actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+          itemFull <- getsState $ itemToFull iid+          localTime <- getsState $ getLocalTime (blid b)+          found <- getsState $ findIid leader side iid+          let !_A = assert (not (null found) || fromCStore == CGround+                            `blame` (iid, leader)) ()+              fAlt (aid, (_, store)) = aid /= leader || store /= fromCStore+              foundAlt = filter fAlt found+              markParagraphs = rheight >= 45+              meleeSkill = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk+              partRawActor aid = getsSession (partActor . getActorUI aid)+              ppLoc aid store = do+                parts <- ppContainerWownW partRawActor+                                          False+                                          (CActor aid store)+                return $! "[" ++ T.unpack (makePhrase parts) ++ "]"+              dmode = MStore fromCStore+          foundTexts <- mapM (\(aid, (_, store)) -> ppLoc aid store) foundAlt+          (ovLab, ovDesc) <-+            itemDescOverlays markParagraphs meleeSkill dmode iid kit+                             itemFull rwidth+          let foundPrefix = textToAS $+                if null foundTexts then "" else "The item is also in:"+              ovPrefix = ytranslateOverlay (length ovDesc)+                         $ offsetOverlay+                         $ splitAttrString rwidth rwidth foundPrefix+              ystart = length ovDesc + length ovPrefix - 1+              xstart = textSize monoFont (Color.spaceAttrW32+                                          : attrLine (snd $ last ovPrefix))+              foundKeys = map (K.KM K.NoModifier . K.Fun)+                              [1 .. length foundAlt]  -- starting from 1!+          let ks = zip foundKeys foundTexts+              width = if isSquareFont monoFont then 2 * rwidth else rwidth+              (ovFoundRaw, kxsFound) = wrapOKX monoFont ystart xstart width ks+              ovFound = ovPrefix ++ ovFoundRaw+          report <- getReportUI True+          CCUI{coinput} <- getsSession sccui+          mstash <- getsState $ \s -> gstash $ sfactionD s EM.! side+          curTutorial <- getsSession scurTutorial+          overrideTut <- getsSession soverrideTut+          let displayTutorialHints = fromMaybe curTutorial overrideTut+              calmE = calmEnough b actorCurAndMaxSk+              greyedOut cmd = not calmE && fromCStore == CEqp+                              || mstash == Just (blid b, bpos b)+                                 && fromCStore == CGround+                              || case cmd of+                ByAimMode AimModeCmd{..} ->+                  greyedOut exploration || greyedOut aiming+                ComposeIfLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2+                ComposeUnlessError cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2+                Compose2ndLocal cmd1 cmd2 -> greyedOut cmd1 || greyedOut cmd2+                MoveItem stores destCStore _ _ ->+                  fromCStore `notElem` stores+                  || destCStore == CEqp && (not calmE || eqpOverfull b 1)+                  || destCStore == CGround && mstash == Just (blid b, bpos b)+                Apply{} ->+                  let skill = Ability.getSk Ability.SkApply actorCurAndMaxSk+                  in not $ fromRight False+                         $ permittedApply corule localTime skill calmE+                                          (Just fromCStore) itemFull kit+                Project{} ->+                  let skill = Ability.getSk Ability.SkProject actorCurAndMaxSk+                  in not $ fromRight False+                         $ permittedProject False skill calmE itemFull+                _ -> False+              fmt n k h = " " <> T.justifyLeft n ' ' k <> " " <> h+              offsetCol2 = 11+              keyCaption = fmt offsetCol2 "keys" "command"+              offset = 1 + maxYofOverlay (ovDesc ++ ovFound)+              (ov0, kxs0) = xytranslateOKX 0 offset $+                 okxsN coinput monoFont propFont offsetCol2 greyedOut+                       True CmdItemMenu ([], [], ["", keyCaption]) ([], [])+              t0 = makeSentence [ MU.SubjectVerbSg (partActor bUI) "choose"+                                , "an item", MU.Text $ ppCStoreIn fromCStore ]+              alRep = foldr (<+:>) [] $ renderReport True report+              al1 | null alRep = textToAS t0+                  | otherwise = alRep ++ stringToAS "\n" ++ textToAS t0+              splitHelp (al, okx) =+                splitOKX fontSetup False rwidth (rheight - 2) rwidth al+                         [K.spaceKM, K.escKM] okx+              sli = toSlideshow fontSetup displayTutorialHints+                    $ splitHelp ( al1+                                , ( EM.insertWith (++) squareFont ovLab+                                    $ EM.insertWith (++) propFont ovDesc+                                    $ EM.insertWith (++) monoFont ovFound ov0+                                        -- mono font, because there are buttons+                                  , kxsFound ++ kxs0 ))+              extraKeys = [K.spaceKM, K.escKM] ++ foundKeys+          recordHistory  -- report shown (e.g., leader switch), save to history+          ekm <- displayChoiceScreen "item menu" ColorFull False sli extraKeys+          case ekm of+            Left km -> case km `M.lookup` bcmdMap coinput of+              _ | km == K.escKM -> weaveJust <$> failWith "never mind"+              _ | km == K.spaceKM ->+                chooseItemMenuHuman leader cmdSemInCxtOfKM dmode+              _ | km `elem` foundKeys -> case km of+                K.KM{key=K.Fun n} -> do+                  let (newAid, (bNew, newCStore)) = foundAlt !! (n - 1)+                  fact <- getsState $ (EM.! side) . sfactionD+                  let banned = bannedPointmanSwitchBetweenLevels fact+                  if blid bNew /= blid b && banned+                  then weaveJust <$> failSer NoChangeDunLeader+                  else do+                    -- Verbosity not necessary to notice the switch+                    -- and it's explicitly requested, so no surprise.+                    void $ pickLeader False newAid+                    modifySession $ \sess ->+                      sess {sitemSel = Just (iid, newCStore, False)}+                    itemMenuHuman newAid cmdSemInCxtOfKM+                _ -> error $ "" `showFailure` km+              Just (_desc, _cats, cmd) -> do+                modifySession $ \sess ->+                  sess {sitemSel = Just (iid, fromCStore, True)}+                cmdSemInCxtOfKM km cmd+              Nothing -> weaveJust <$> failWith "never mind"+            Right _slot -> error $ "" `showFailure` ekm+    Nothing -> weaveJust <$> failWith "no item to open item menu for"++-- * ChooseItemMenu++chooseItemMenuHuman :: MonadClientUI m+                    => ActorId+                    -> (K.KM -> HumanCmd -> m (Either MError ReqUI))+                    -> ItemDialogMode+                    -> m (Either MError ReqUI)+chooseItemMenuHuman leader1 cmdSemInCxtOfKM c1 = do+  res2 <- chooseItemDialogMode leader1 True c1+  case res2 of+    Right leader2 -> itemMenuHuman leader2 cmdSemInCxtOfKM+    Left err -> return $ Left $ Just err++-- * MainMenu++generateMenu :: MonadClientUI m+             => (K.KM -> HumanCmd -> m (Either MError ReqUI))+             -> FontOverlayMap+             -> [(Text, HumanCmd, Maybe HumanCmd, Maybe FontOverlayMap)]+             -> [String]+             -> String+             -> m (Either MError ReqUI)+generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName = do+  COps{corule} <- getsState scops+  CCUI{ coinput=InputContent{brevMap}+      , coscreen=ScreenContent{rheight, rwebAddress} } <- getsSession sccui+  FontSetup{..} <- getFontSetup+  let matchKM slot kd@(_, cmd, _, _) = case M.lookup cmd brevMap of+        Just (km : _) -> (Left km, kd)+        _ -> (Right slot, kd)+      kds = zipWith matchKM natSlots kdsRaw+      bindings =  -- key bindings to display+        let attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor}+            highAttr ac = ac {Color.acAttr = attrCursor}+            highW32 = Color.attrCharToW32 . highAttr . Color.attrCharFromW32+            markFirst d = markFirstAS $ textToAS d+            markFirstAS [] = []+            markFirstAS (ac : rest) = highW32 ac : rest+            fmt (ekm, (d, _, _, _)) = (ekm, markFirst d)+        in map fmt kds+      generate :: Int -> (KeyOrSlot, AttrString) -> KYX+      generate y (ekm, binding) =+        (ekm, (PointUI 0 y, ButtonWidth squareFont (length binding)))+      okxBindings = ( EM.singleton squareFont+                      $ offsetOverlay $ map (attrStringToAL . snd) bindings+                    , zipWith generate [0..] bindings )+      titleLine =+        rtitle corule ++ " " ++ showVersion (rexeVersion corule) ++ " "+      titleAndInfo = map stringToAL+                         ([ ""+                          , titleLine ++ "[" ++ rwebAddress ++ "]"+                          , "" ]+                          ++ gameInfo)+      webButton = ( Left $ K.mkChar '@'  -- to start the menu not here+                  , ( PointUI (2 * length titleLine) 1+                    , ButtonWidth squareFont (2 + length rwebAddress) ) )+      okxTitle = ( EM.singleton squareFont $ offsetOverlay titleAndInfo+                 , [webButton] )+      okx = xytranslateOKX 2 0+            $ sideBySideOKX 2 (length titleAndInfo) okxTitle okxBindings+      prepareBlurb ovs =+        let introLen = 1 + maxYofFontOverlayMap ovs+            start0 = max 0 (rheight - introLen+                            - if isSquareFont propFont then 1 else 2)+        in EM.map (xytranslateOverlay (-2) (start0 - 2)) ovs+          -- subtracting 2 from X and Y to negate the indentation in+          -- @displayChoiceScreenWithRightPane@+      returnDefaultOKS = return (prepareBlurb blurb, [])+      displayInRightPane ekm = case ekm `lookup` kds of+        Just (_, _, _, mblurbRight) -> case mblurbRight of+          Nothing -> returnDefaultOKS+          Just blurbRight -> return (prepareBlurb blurbRight, [])+        Nothing | ekm == Left (K.mkChar '@') -> returnDefaultOKS+        Nothing -> error $ "generateMenu: unexpected key:"+                           `showFailure` ekm+      keys = [K.leftKM, K.rightKM, K.escKM, K.mkChar '@']+      loop = do+        kmkm <- displayChoiceScreenWithRightPaneKMKM displayInRightPane True+                                                     menuName ColorFull True+                                                     (menuToSlideshow okx) keys+        case kmkm of+          Left (km@(K.KM {key=K.Left}), ekm) -> case ekm `lookup` kds of+            Just (_, _, Nothing, _) -> loop+            Just (_, _, Just cmdReverse, _) -> cmdSemInCxtOfKM km cmdReverse+            Nothing -> weaveJust <$> failWith "never mind"+          Left (km@(K.KM {key=K.Right}), ekm) -> case ekm `lookup` kds of+            Just (_, cmd, _, _) -> cmdSemInCxtOfKM km cmd+            Nothing -> weaveJust <$> failWith "never mind"+          Left (K.KM {key=K.Char '@'}, _)-> do+            success <- tryOpenBrowser rwebAddress+            if success+            then generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName+            else weaveJust <$> failWith "failed to open web browser"+          Left (km, _) -> case Left km `lookup` kds of+            Just (_, cmd, _, _) -> cmdSemInCxtOfKM km cmd+            Nothing -> weaveJust <$> failWith "never mind"+          Right slot -> case Right slot `lookup` kds of+            Just (_, cmd, _, _) -> cmdSemInCxtOfKM K.escKM cmd+            Nothing -> weaveJust <$> failWith "never mind"+  loop++-- | Display the main menu.+mainMenuHuman :: MonadClientUI m+              => (K.KM -> HumanCmd -> m (Either MError ReqUI))+              -> m (Either MError ReqUI)+mainMenuHuman cmdSemInCxtOfKM = do+  CCUI{coscreen=ScreenContent{rintroScreen}} <- getsSession sccui+  FontSetup{propFont} <- getFontSetup+  gameMode <- getGameMode+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  curChal <- getsClient scurChal+  let offOn b = if b then "on" else "off"+      -- Key-description-command tuples.+      kds = [ ("+ setup and start new game>", ChallengeMenu, Nothing, Nothing)+            , ("@ save and exit to desktop", GameExit, Nothing, Nothing)+            , ("+ tweak convenience settings>", SettingsMenu, Nothing, Nothing)+            , ("@ toggle autoplay", AutomateToggle, Nothing, Nothing)+            , ("@ see command help", Help, Nothing, Nothing)+            , ("@ switch to dashboard", Dashboard, Nothing, Nothing)+            , ("^ back to playing", AutomateBack, Nothing, Nothing) ]+      gameName = MK.mname gameMode+      displayTutorialHints = fromMaybe curTutorial overrideTut+      gameInfo = map T.unpack+                   [ "Now playing:" <+> gameName+                   , ""+                   , "      with difficulty:" <+> tshow (cdiff curChal)+                   , "            cold fish:" <+> offOn (cfish curChal)+                   , "          ready goods:" <+> offOn (cgoods curChal)+                   , "            lone wolf:" <+> offOn (cwolf curChal)+                   , "        finder keeper:" <+> offOn (ckeeper curChal)+                   , "       tutorial hints:" <+> offOn displayTutorialHints+                   , "" ]+      glueLines (l1 : l2 : rest) =+        if | null l1 -> l1 : glueLines (l2 : rest)+           | null l2 -> l1 : l2 : glueLines rest+           | otherwise -> (l1 ++ l2) : glueLines rest+      glueLines ll = ll+      backstory | isSquareFont propFont = fst rintroScreen+                | otherwise = glueLines $ fst rintroScreen+      backstoryAL = map (stringToAL . dropWhile (== ' ')) backstory+      blurb = attrLinesToFontMap [(propFont, backstoryAL)]+  generateMenu cmdSemInCxtOfKM blurb kds gameInfo "main"++-- * MainMenuAutoOn++-- | Display the main menu and set @swasAutomated@.+mainMenuAutoOnHuman :: MonadClientUI m+                    => (K.KM -> HumanCmd -> m (Either MError ReqUI))+                    -> m (Either MError ReqUI)+mainMenuAutoOnHuman cmdSemInCxtOfKM = do+  modifySession $ \sess -> sess {swasAutomated = True}+  mainMenuHuman cmdSemInCxtOfKM++-- * MainMenuAutoOff++-- | Display the main menu and unset @swasAutomated@.+mainMenuAutoOffHuman :: MonadClientUI m+                     => (K.KM -> HumanCmd -> m (Either MError ReqUI))+                     -> m (Either MError ReqUI)+mainMenuAutoOffHuman cmdSemInCxtOfKM = do+  modifySession $ \sess -> sess {swasAutomated = False}+  mainMenuHuman cmdSemInCxtOfKM++-- * SettingsMenu++-- | Display the settings menu.+settingsMenuHuman :: MonadClientUI m+                  => (K.KM -> HumanCmd -> m (Either MError ReqUI))+                  -> m (Either MError ReqUI)+settingsMenuHuman cmdSemInCxtOfKM = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  UIOptions{uMsgWrapColumn} <- getsSession sUIOptions+  FontSetup{..} <- getFontSetup+  markSuspect <- getsClient smarkSuspect+  markVision <- getsSession smarkVision+  markSmell <- getsSession smarkSmell+  noAnim <- getsClient $ fromMaybe False . snoAnim . soptions+  side <- getsClient sside+  factDoctrine <- getsState $ gdoctrine . (EM.! side) . sfactionD+  overrideTut <- getsSession soverrideTut+  let offOn b = if b then "on" else "off"+      offOnAll n = case n of+        0 -> "none"+        1 -> "untried"+        2 -> "all"+        _ -> error $ "" `showFailure` n+      neverEver n = case n of+        0 -> "never"+        1 -> "aiming"+        2 -> "always"+        _ -> error $ "" `showFailure` n+      offOnUnset mb = case mb of+        Nothing -> "pass"+        Just b -> if b then "force on" else "force off"+      tsuspect = "@ mark suspect terrain:" <+> offOnAll markSuspect+      tvisible = "@ show visible zone:" <+> neverEver markVision+      tsmell = "@ display smell clues:" <+> offOn markSmell+      tanim = "@ play animations:" <+> offOn (not noAnim)+      tdoctrine = "@ squad doctrine:" <+> Ability.nameDoctrine factDoctrine+      toverride = "@ override tutorial hints:" <+> offOnUnset overrideTut+      width = if isSquareFont propFont+              then rwidth `div` 2+              else min uMsgWrapColumn (rwidth - 2)+      textToBlurb t = Just $ attrLinesToFontMap+        [ ( propFont+          , splitAttrString width width+            $ textToAS t ) ]+      -- Key-description-command-text tuples.+      kds = [ ( tsuspect, MarkSuspect 1, Just (MarkSuspect (-1))+              , textToBlurb "* mark suspect terrain\nThis setting affects the ongoing and the next games. It determines which suspect terrain is marked in special color on the map: none, untried (not searched nor revealed), all. It correspondingly determines which, if any, suspect tiles are considered for mouse go-to, auto-explore and for the command that marks the nearest unexplored position." )+            , ( tvisible, MarkVision 1, Just (MarkVision (-1))+              , textToBlurb "* show visible zone\nThis setting affects the ongoing and the next games. It determines the conditions under which the area visible to the party is marked on the map via a gray background: never, when aiming, always." )+            , ( tsmell, MarkSmell, Just MarkSmell+              , textToBlurb "* display smell clues\nThis setting affects the ongoing and the next games. It determines whether the map displays any smell traces (regardless of who left them) detected by a party member that can track via smell (as determined by the smell radius skill; not common among humans)." )+            , ( tanim, MarkAnim, Just MarkAnim+              , textToBlurb "* play animations\nThis setting affects the ongoing and the next games. It determines whether important events, such combat, are highlighted by animations. This overrides the corresponding config file setting." )+            , ( tdoctrine, Doctrine, Nothing+              , textToBlurb "* squad doctrine\nThis setting affects the ongoing game, but does not persist to the next games. It determines the behaviour of henchmen (non-pointman characters) in the party and, in particular, if they are permitted to move autonomously or fire opportunistically (assuming they are able to, usually due to rare equipment). This setting has a poor UI that will be improved in the future." )+            , ( toverride, OverrideTut 1, Just (OverrideTut (-1))+              , textToBlurb "* override tutorial hints\nThis setting affects the ongoing and the next games. It determines whether tutorial hints are, respectively, not overridden with respect to the default game mode setting, forced to be off, forced to be on. Tutorial hints are rendered as pink messages and can afterwards be re-read from message history." )+            , ( "^ back to main menu", MainMenu, Nothing, Just EM.empty ) ]+      gameInfo = map T.unpack+                   [ "Tweak convenience settings:"+                   , "" ]+  generateMenu cmdSemInCxtOfKM EM.empty kds gameInfo "settings"++-- * ChallengeMenu++-- | Display the challenge menu.+challengeMenuHuman :: MonadClientUI m+                   => (K.KM -> HumanCmd -> m (Either MError ReqUI))+                   -> m (Either MError ReqUI)+challengeMenuHuman cmdSemInCxtOfKM = do+  cops <- getsState scops+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  UIOptions{uMsgWrapColumn} <- getsSession sUIOptions+  FontSetup{..} <- getFontSetup+  svictories <- getsSession svictories+  snxtScenario <- getsSession snxtScenario+  nxtChal <- getsClient snxtChal+  let (gameModeId, gameMode) = nxtGameMode cops snxtScenario+      victories = case EM.lookup gameModeId svictories of+        Nothing -> 0+        Just cm -> fromMaybe 0 (M.lookup nxtChal cm)+      star t = if victories > 0 then "*" <> t else t+      tnextScenario = "@ adventure:" <+> star (MK.mname gameMode)+      offOn b = if b then "on" else "off"+      tnextDiff = "@ difficulty level:" <+> tshow (cdiff nxtChal)+      tnextFish = "@ cold fish (rather hard):" <+> offOn (cfish nxtChal)+      tnextGoods = "@ ready goods (hard):" <+> offOn (cgoods nxtChal)+      tnextWolf = "@ lone wolf (very hard):" <+> offOn (cwolf nxtChal)+      tnextKeeper = "@ finder keeper (hard):" <+> offOn (ckeeper nxtChal)+      width = if isSquareFont propFont+              then rwidth `div` 2+              else min uMsgWrapColumn (rwidth - 2)+      widthFull = if isSquareFont propFont+                  then rwidth `div` 2+                  else rwidth - 2+      duplicateEOL '\n' = "\n\n"+      duplicateEOL c = T.singleton c+      blurb = Just $ attrLinesToFontMap+        [ ( propFont+          , splitAttrString width width+            $ textFgToAS Color.BrBlack+            $ T.concatMap duplicateEOL (MK.mdesc gameMode)+              <> "\n\n" )+        , ( propFont+          , splitAttrString widthFull widthFull+            $ textToAS+            $ MK.mrules gameMode+              <> "\n\n" )+        , ( propFont+          , splitAttrString width width+            $ textToAS+            $ T.concatMap duplicateEOL (MK.mreason gameMode) )+        ]+      textToBlurb t = Just $ attrLinesToFontMap+        [ ( propFont+          , splitAttrString width width  -- not widthFull!+            $ textToAS t ) ]+      -- Key-description-command-text tuples.+      kds = [ ( tnextScenario, GameScenarioIncr 1, Just (GameScenarioIncr (-1))+              , blurb )+            , ( tnextDiff, GameDifficultyIncr 1, Just (GameDifficultyIncr (-1))+              , textToBlurb "* difficulty level\nThis determines the difficulty of survival in the next game that's about to be started. Lower numbers result in easier game. In particular, difficulty below 5 multiplies hitpoints of player characters and difficulty over 5 multiplies hitpoints of their enemies. Game score scales with difficulty.")+            , ( tnextFish, GameFishToggle, Just GameFishToggle+              , textToBlurb "* cold fish\nThis challenge mode setting will affect the next game that's about to be started. When on, it makes it impossible for player characters to be healed by actors from other factions (this is a significant restriction in the long crawl adventure).")+            , ( tnextGoods, GameGoodsToggle, Just GameGoodsToggle+              , textToBlurb "* ready goods\nThis challenge mode setting will affect the next game that's about to be started. When on, it disables crafting for the player, making the selection of equipment, especially melee weapons, very limited, unless the player has the luck to find the rare powerful ready weapons (this applies only if the chosen adventure supports crafting at all).")+            , ( tnextWolf, GameWolfToggle, Just GameWolfToggle+              , textToBlurb "* lone wolf\nThis challenge mode setting will affect the next game that's about to be started. When on, it reduces player's starting actors to exactly one, though later on new heroes may join the party. This makes the game very hard in the long run.")+            , ( tnextKeeper, GameKeeperToggle, Just GameKeeperToggle+              , textToBlurb "* finder keeper\nThis challenge mode setting will affect the next game that's about to be started. When on, it completely disables flinging projectiles by the player, which affects not only ranged damage dealing, but also throwing of consumables that buff teammates engaged in melee combat, weaken and distract enemies, light dark corners, etc.")+            , ( "@ start new game", GameRestart, Nothing, blurb )+            , ( "^ back to main menu", MainMenu, Nothing, Nothing ) ]+      gameInfo = map T.unpack [ "Setup and start new game:"+                              , "" ]+  generateMenu cmdSemInCxtOfKM EM.empty kds gameInfo "challenge"++-- * GameDifficultyIncr++gameDifficultyIncr :: MonadClient m => Int -> m ()+gameDifficultyIncr delta = do+  nxtDiff <- getsClient $ cdiff . snxtChal+  let d | nxtDiff + delta > difficultyBound = 1+        | nxtDiff + delta < 1 = difficultyBound+        | otherwise = nxtDiff + delta+  modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cdiff = d} }++-- * GameFishToggle++gameFishToggle :: MonadClient m => m ()+gameFishToggle =+  modifyClient $ \cli ->+    cli {snxtChal = (snxtChal cli) {cfish = not (cfish (snxtChal cli))} }++-- * GameGoodsToggle++gameGoodsToggle :: MonadClient m => m ()+gameGoodsToggle =+  modifyClient $ \cli ->+    cli {snxtChal = (snxtChal cli) {cgoods = not (cgoods (snxtChal cli))} }++-- * GameWolfToggle++gameWolfToggle :: MonadClient m => m ()+gameWolfToggle =+  modifyClient $ \cli ->+    cli {snxtChal = (snxtChal cli) {cwolf = not (cwolf (snxtChal cli))} }++-- * GameKeeperToggle++gameKeeperToggle :: MonadClient m => m ()+gameKeeperToggle =+  modifyClient $ \cli ->+    cli {snxtChal = (snxtChal cli) {ckeeper = not (ckeeper (snxtChal cli))} }++-- * GameScenarioIncr++gameScenarioIncr :: MonadClientUI m => Int -> m ()+gameScenarioIncr delta = do+  cops <- getsState scops+  oldScenario <- getsSession snxtScenario+  let snxtScenario = oldScenario + delta+      snxtTutorial = MK.mtutorial $ snd $ nxtGameMode cops snxtScenario+  modifySession $ \sess -> sess {snxtScenario, snxtTutorial}++-- * GameRestart & GameQuit++data ExitStrategy = Restart | Quit++gameExitWithHuman :: MonadClientUI m => ExitStrategy -> m (FailOrCmd ReqUI)+gameExitWithHuman exitStrategy = do+  snxtChal       <- getsClient snxtChal+  cops           <- getsState scops+  noConfirmsGame <- isNoConfirmsGame+  gameMode       <- getGameMode+  snxtScenario   <- getsSession snxtScenario+  let nxtGameName = MK.mname $ snd $ nxtGameMode cops snxtScenario+      exitReturn x = return $ Right $ ReqUIGameRestart x snxtChal+      displayExitMessage diff =+        displayYesNo ColorBW+        $ diff <+> "progress of the ongoing"+          <+> MK.mname gameMode <+> "game will be lost! Are you sure?"+  ifM (if' noConfirmsGame+           (return True)  -- true case+           (displayExitMessage $ case exitStrategy of  -- false case+              Restart -> "You just requested a new" <+> nxtGameName+                         <+> "game. The "+              Quit -> "If you quit, the "))+      (exitReturn $ case exitStrategy of  -- ifM true case+         Restart ->+           let (mainName, _) = T.span (\c -> Char.isAlpha c || c == ' ')+                                      nxtGameName+           in DefsInternal.GroupName $ T.intercalate " "+              $ take 2 $ T.words mainName+         Quit -> MK.INSERT_COIN)+      (rndToActionUI (oneOf  -- ifM false case+                        [ "yea, would be a pity to leave them to die"+                        , "yea, a shame to get your team stranded" ])+       >>= failWith)++ifM :: Monad m => m Bool -> m b -> m b -> m b+ifM b t f = do b' <- b; if b' then t else f++if' :: Bool -> p -> p -> p+if' b t f = if b then t else f++-- * GameDrop++gameDropHuman :: MonadClientUI m => m ReqUI+gameDropHuman = do+  modifySession $ \sess -> sess {sallNframes = -1}  -- hack, but we crash anyway+  msgAdd MsgPromptGeneric "Interrupt! Trashing the unsaved game. The program exits now."+  clientPrintUI "Interrupt! Trashing the unsaved game. The program exits now."+    -- this is not shown by ANSI frontend, but at least shown by sdl2 one+  return ReqUIGameDropAndExit++-- * GameExit++gameExitHuman :: Monad m => m ReqUI+gameExitHuman =+  return ReqUIGameSaveAndExit++-- * GameSave++gameSaveHuman :: MonadClientUI m => m ReqUI+gameSaveHuman = do+  -- Announce before the saving started, since it can take a while.+  msgAdd MsgInnerWorkSpam "Saving game backup."+  return ReqUIGameSave++-- * Doctrine++-- Note that the difference between seek-target and follow-the-leader doctrine+-- can influence even a faction with passive actors. E.g., if a passive actor+-- has an extra active skill from equipment, he moves every turn.+doctrineHuman :: MonadClientUI m => m (FailOrCmd ReqUI)+doctrineHuman = do+  fid <- getsClient sside+  fromT <- getsState $ gdoctrine . (EM.! fid) . sfactionD+  let toT = if fromT == maxBound then minBound else succ fromT+  go <- displaySpaceEsc ColorFull+        $ "(Beware, work in progress!)"+          <+> "Current squad doctrine is '" <> Ability.nameDoctrine fromT <> "'"+          <+> "(" <> Ability.describeDoctrine fromT <> ")."+          <+> "Switching doctrine to '" <> Ability.nameDoctrine toT <> "'"+          <+> "(" <> Ability.describeDoctrine toT <> ")."+          <+> "This clears targets of all non-pointmen teammates."+          <+> "New targets will be picked according to new doctrine."+  if not go+  then failWith "squad doctrine change canceled"+  else return $ Right $ ReqUIDoctrine toT++-- * Automate++automateHuman :: MonadClientUI m => m (FailOrCmd ReqUI)+automateHuman = do+  clearAimMode+  proceed <- displayYesNo ColorBW "Do you really want to cede control to AI?"+  if not proceed+  then failWith "automation canceled"+  else return $ Right ReqUIAutomate++-- * AutomateToggle++automateToggleHuman :: MonadClientUI m => m (FailOrCmd ReqUI)+automateToggleHuman = do+  swasAutomated <- getsSession swasAutomated+  if swasAutomated+  then failWith "automation canceled"+  else automateHuman++-- * AutomateBack++automateBackHuman :: MonadClientUI m => m (Either MError ReqUI)+automateBackHuman = do+  swasAutomated <- getsSession swasAutomated+  return $! if swasAutomated+            then Right ReqUIAutomate+            else Left Nothing
+ engine-src/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs view
@@ -0,0 +1,1357 @@+-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd"+-- client commands that do not return server requests,,+-- but only change internal client state.+-- None of such commands takes game time.+module Game.LambdaHack.Client.UI.HandleHumanLocalM+  ( -- * Meta commands+    macroHuman, macroHumanTransition+    -- * Local commands+  , chooseItemHuman, chooseItemDialogMode+  , chooseItemProjectHuman, chooseItemApplyHuman+  , psuitReq, triggerSymbols, pickLeaderHuman, pickLeaderWithPointerHuman+  , pointmanCycleHuman, pointmanCycleLevelHuman+  , selectActorHuman, selectNoneHuman, selectWithPointerHuman+  , repeatHuman, repeatHumanTransition+  , repeatLastHuman, repeatLastHumanTransition+  , recordHuman, recordHumanTransition, allHistoryHuman+  , markVisionHuman, markSmellHuman, markSuspectHuman, markAnimHuman+  , overrideTutHuman+  , printScreenHuman+    -- * Commands specific to aiming+  , cancelHuman, acceptHuman, detailCycleHuman+  , clearTargetIfItemClearHuman, itemClearHuman+  , moveXhairHuman, aimTgtHuman, aimFloorHuman, aimEnemyHuman, aimItemHuman+  , aimAscendHuman, epsIncrHuman+  , xhairUnknownHuman, xhairItemHuman, xhairStairHuman+  , xhairPointerFloorHuman, xhairPointerMuteHuman, xhairPointerEnemyHuman+  , aimPointerFloorHuman, aimPointerEnemyHuman+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , chooseItemDialogModeLore, projectCheck+  , posFromXhair, permittedApplyClient, endAiming, endAimingMsg+  , flashAiming+#endif+    -- * Operations both internal and used in unit tests+  , permittedProjectClient, xhairLegalEps+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Either+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Animation+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.DrawM+import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.HandleHelperM+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import           Game.LambdaHack.Client.UI.InventoryM+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.FactionKind as FK+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.ModeKind as MK+import           Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs++-- * Macro++macroHuman :: MonadClientUI m => [String] -> m ()+macroHuman ks = do+  modifySession $ \sess ->+    let kms = K.mkKM <$> ks+        (smacroFrameNew, smacroStackMew) =+           macroHumanTransition kms (smacroFrame sess) (smacroStack sess)+    in sess { smacroFrame = smacroFrameNew+            , smacroStack = smacroStackMew }+  msgAdd MsgMacroOperation $ "Macro activated:" <+> T.pack (unwords ks)++-- | Push a new macro frame to the stack whenever repeating a macro.+macroHumanTransition :: [K.KM] -> KeyMacroFrame -> [KeyMacroFrame]+                     -> (KeyMacroFrame, [KeyMacroFrame])+macroHumanTransition kms macroFrame macroFrames =+  let smacroFrameNew = emptyMacroFrame {keyPending = KeyMacro kms}+  in (smacroFrameNew, macroFrame : macroFrames)++-- * ChooseItem++-- | Display items from a given container store and possibly let the user+-- chose one.+chooseItemHuman :: MonadClientUI m => ActorId -> ItemDialogMode -> m MError+chooseItemHuman leader c =+  either Just (const Nothing) <$> chooseItemDialogMode leader False c++chooseItemDialogModeLore :: forall m . MonadClientUI m+                         => m (Maybe ResultItemDialogMode)+chooseItemDialogModeLore = do+  schosenLoreOld <- getsSession schosenLore+  (inhabitants, embeds) <- case schosenLoreOld of+    ChosenLore inh emb -> return (inh, emb)+    ChosenNothing -> computeChosenLore+  bagHuge <- getsState $ EM.map (const quantSingle) . sitemD+  itemToF <- getsState $ flip itemToFull+  ItemRoles itemRoles <- getsSession sroles+  let rlore :: ItemId -> SLore -> ChosenLore -> m (Maybe ResultItemDialogMode)+      rlore iid slore schosenLore = do+        let itemRole = itemRoles EM.! slore+            bagAll = EM.filterWithKey (\iid2 _ -> iid2 `ES.member` itemRole)+                                      bagHuge+        modifySession $ \sess -> sess {schosenLore}+        let iids = sortIids itemToF $ EM.assocs bagAll+            slot = toEnum $ fromMaybe (error $ "" `showFailure` (iid, iids))+                          $ elemIndex iid $ map fst iids+        return $ Just $ RLore slore slot iids+  case inhabitants of+    (_, b) : rest -> do+      let iid = btrunk b+      arItem <- getsState $ aspectRecordFromIid iid+      let slore | not $ bproj b = STrunk+                | IA.checkFlag Ability.Blast arItem = SBlast+                | otherwise = SItem+      rlore iid slore (ChosenLore rest embeds)+    [] ->+      case embeds of+        (iid, _) : rest -> do+          let slore = SEmbed+          rlore iid slore (ChosenLore inhabitants rest)+        [] -> do+          modifySession $ \sess -> sess {schosenLore = ChosenNothing}+          return Nothing++chooseItemDialogMode :: forall m. MonadClientUI m+                     => ActorId -> Bool -> ItemDialogMode+                     -> m (FailOrCmd ActorId)+chooseItemDialogMode leader0 permitLoreCycle c = do+  CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+  FontSetup{propFont} <- getFontSetup+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  (ggi, loreFound) <- do+    mggiLore <- if permitLoreCycle && c == MLore SItem+                then chooseItemDialogModeLore+                else return Nothing+    case mggiLore of+      Just rlore -> return (Right rlore, True)+      Nothing -> do+        ggi <- getStoreItem leader0 c+        return (ggi, False)+  -- Pointman could have been changed in @getStoreItem@ above.+  mleader <- getsClient sleader+  -- When run inside a test, without mleader, assume leader not changed.+  let leader = fromMaybe leader0 mleader+  recordHistory  -- item chosen, wipe out already shown msgs+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  let meleeSkill = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk+  bUI <- getsSession $ getActorUI leader+  case ggi of+    Right result -> case result of+      RStore fromCStore [iid] -> do+        modifySession $ \sess ->+          sess {sitemSel = Just (iid, fromCStore, False)}+        return $ Right leader+      RStore{} -> error $ "" `showFailure` result+      ROwned iid -> do+        found <- getsState $ findIid leader side iid+        let (newAid, bestStore) = case leader `lookup` found of+              Just (_, store) -> (leader, store)+              Nothing -> case found of+                (aid, (_, store)) : _ -> (aid, store)+                [] -> error $ "" `showFailure` result+        modifySession $ \sess ->+          sess {sitemSel = Just (iid, bestStore, False)}+        arena <- getArenaUI+        b2 <- getsState $ getActorBody newAid+        let banned = bannedPointmanSwitchBetweenLevels fact+        if | newAid == leader -> return $ Right leader+           | blid b2 /= arena && banned ->+             failSer NoChangeDunLeader+           | otherwise -> do+             -- We switch leader only here, not when processing results+             -- of lore screens, because lore is only about inspecting items.+             --+             -- This is a bit too verbose in aiming mode, but verbosity+             -- here is good to turn player's attention to the switch.+             void $ pickLeader True newAid+             return $ Right newAid+      RLore slore slot iids -> do+        let promptFun _ itemFull _ = case slore of+              SBody ->+                let blurb = if IA.checkFlag Ability.Condition+                               $ aspectRecordFull itemFull+                            then "condition"+                            else "organ"+                in makeSentence [partActor bUI, "is aware of" ,MU.AW blurb]+              _ ->+                makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember"+                             , MU.AW $ MU.Text (headingSLore slore) ]+        schosenLore <- getsSession schosenLore+        let lorePending = loreFound && case schosenLore of+              ChosenLore [] [] -> False+              _ -> True+            renderOneItem =+              okxItemLoreMsg promptFun meleeSkill (MLore slore) iids+            extraKeys = [K.mkChar '~' | lorePending]+            slotBound = length iids - 1+        km <- displayOneMenuItem renderOneItem extraKeys slotBound slot+        case K.key km of+          K.Space -> do+            modifySession $ \sess -> sess {schosenLore = ChosenNothing}+            chooseItemDialogMode leader False (MLore slore)+          K.Char '~' -> chooseItemDialogMode leader True c+          K.Esc -> do+            modifySession $ \sess -> sess {schosenLore = ChosenNothing}+            failWith "never mind"+          _ -> error $ "" `showFailure` km+      RSkills slot0 -> do+        -- This can be used in the future, e.g., to increase stats from+        -- level-up stat points, so let's keep it even if it shows+        -- no extra info compared to right pane display in menu.+        let renderOneItem slot = do+              (prompt2, attrString) <- skillCloseUp leader slot+              let ov0 = EM.singleton propFont+                        $ offsetOverlay+                        $ splitAttrString rwidth rwidth attrString+              msgAdd MsgPromptGeneric prompt2+              return (ov0, [])+            extraKeys = []+            slotBound = length skillsInDisplayOrder - 1+        km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0+        case K.key km of+          K.Space -> chooseItemDialogMode leader False MSkills+          K.Esc -> failWith "never mind"+          _ -> error $ "" `showFailure` km+      RPlaces slot0 -> do+        COps{coplace} <- getsState scops+        soptions <- getsClient soptions+        -- This is computed just once for the whole series of up and down arrow+        -- navigations, avoid quadratic blowup.+        places <- getsState $ EM.assocs+                              . placesFromState coplace (sexposePlaces soptions)+        let renderOneItem slot = do+              (prompt2, blurbs) <-+                placeCloseUp places (sexposePlaces soptions) slot+              let splitText = splitAttrString rwidth rwidth+                  ov0 = attrLinesToFontMap+                        $ map (second $ concatMap splitText) blurbs+              msgAdd MsgPromptGeneric prompt2+              return (ov0, [])+            extraKeys = []+            slotBound = length places - 1+        km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0+        case K.key km of+          K.Space -> chooseItemDialogMode leader False MPlaces+          K.Esc -> failWith "never mind"+          _ -> error $ "" `showFailure` km+      RFactions slot0 -> do+        sroles <- getsSession sroles+        factions <- getsState $ factionsFromState sroles+        let renderOneItem slot = do+              (prompt2, blurbs) <- factionCloseUp factions slot+              let splitText = splitAttrString rwidth rwidth+                  ov0 = attrLinesToFontMap+                        $ map (second $ concatMap splitText) blurbs+              msgAdd MsgPromptGeneric prompt2+              return (ov0, [])+            extraKeys = []+            slotBound = length factions - 1+        km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0+        case K.key km of+          K.Space -> chooseItemDialogMode leader False MFactions+          K.Esc -> failWith "never mind"+          _ -> error $ "" `showFailure` km+      RModes slot0 -> do+        let displayOneMenuItemBig :: (MenuSlot -> m OKX)+                                  -> [K.KM] -> Int -> MenuSlot+                                  -> m K.KM+            displayOneMenuItemBig renderOneItem extraKeys slotBound slot = do+              let keys = [K.spaceKM, K.escKM]+                         ++ [K.upKM | fromEnum slot > 0]+                         ++ [K.downKM | fromEnum slot < slotBound]+                         ++ extraKeys+              okx <- renderOneItem slot+              -- Here it differs from @displayOneMenuItem@,+              slides <- overlayToSlideshow rheight keys okx+              ekm2 <- displayChoiceScreen "" ColorFull True slides keys+              let km = either id (error $ "" `showFailure` ekm2) ekm2+              -- Here it stops differing.+              case K.key km of+                K.Up -> displayOneMenuItemBig renderOneItem extraKeys+                                              slotBound $ pred slot+                K.Down -> displayOneMenuItemBig renderOneItem extraKeys+                                                slotBound $ succ slot+                _ -> return km+        COps{comode} <- getsState scops+        svictories <- getsSession svictories+        nxtChal <- getsClient snxtChal+          -- mark victories only for current difficulty+        let f !acc _p !i !a = (i, a) : acc+            campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f []+            renderOneItem slot = do+              let (gameModeId, gameMode) = campaignModes !! fromEnum slot+              ov0 <- describeMode False gameModeId+              let victories = case EM.lookup gameModeId svictories of+                    Nothing -> 0+                    Just cm -> fromMaybe 0 (M.lookup nxtChal cm)+                  verb = if victories > 0 then "remember" else "forsee"+                  prompt2 = makeSentence+                    [ MU.SubjectVerbSg "you" verb+                    , MU.Text $ "the '" <> MK.mname gameMode <> "' adventure" ]+              msgAdd MsgPromptGeneric prompt2+              return (ov0, [])+            extraKeys = []+            slotBound = length campaignModes - 1+        km <- displayOneMenuItemBig renderOneItem extraKeys slotBound slot0+        case K.key km of+          K.Space -> chooseItemDialogMode leader False MModes+          K.Esc -> failWith "never mind"+          _ -> error $ "" `showFailure` km+    Left err -> failWith err++-- * ChooseItemProject++chooseItemProjectHuman :: forall m. (MonadClient m, MonadClientUI m)+                       => ActorId -> [HumanCmd.TriggerItem] -> m MError+chooseItemProjectHuman leader ts = do+  b <- getsState $ getActorBody leader+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+  let overStash = mstash == Just (blid b, bpos b)+      storesBase = [CStash, CEqp]+      stores | overStash = storesBase ++ [CGround]+             | otherwise = CGround : storesBase+      (verb1, object1) = case ts of+        [] -> ("aim", "item")+        tr : _ -> (HumanCmd.tiverb tr, HumanCmd.tiobject tr)+      verb = makePhrase [verb1]+      triggerSyms = triggerSymbols ts+  mpsuitReq <- psuitReq leader+  case mpsuitReq of+    -- If xhair aim invalid, no item is considered a (suitable) missile.+    Left err -> failMsg err+    Right psuitReqFun -> do+      itemSel <- getsSession sitemSel+      case itemSel of+        Just (_, _, True) -> return Nothing+        Just (iid, fromCStore, False) -> do+          -- We don't validate vs @ts@ here, because player has selected+          -- this item, so he knows what he's doing (unless really absurd).+          itemFull <- getsState $ itemToFull iid+          bag <- getsState $ getBodyStoreBag b fromCStore+          case iid `EM.lookup` bag of+            Just _ | isRight (psuitReqFun itemFull) ->+              -- The player knows what he's doing. We warn him about range+              -- and experimenting with unknown precious items is fine.+              return Nothing+            _ -> do+              modifySession $ \sess -> sess {sitemSel = Nothing}+              chooseItemProjectHuman leader ts+        Nothing -> do+          let psuit =+                return $ SuitsSomething $ \_ itemFull _kit ->+                  -- Here the player does not explicitly pick an item,+                  -- so we may exclude precious unknown items, etc.+                  either (const False) snd (psuitReqFun itemFull)+                  && (null triggerSyms+                      || IK.isymbol (itemKind itemFull) `elem` triggerSyms)+              prompt = makePhrase ["What", object1, "to"]+              promptGeneric = "What to"+          ggi <- getGroupItem leader psuit prompt promptGeneric verb "fling"+                              stores+          case ggi of+            Right (fromCStore, iid) -> do+              modifySession $ \sess ->+                sess {sitemSel = Just (iid, fromCStore, False)}+              return Nothing+            Left err -> failMsg err++permittedProjectClient :: MonadClientUI m+                       => ActorId -> m (ItemFull -> Either ReqFailure Bool)+permittedProjectClient leader = do+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  b <- getsState $ getActorBody leader+  let skill = Ability.getSk Ability.SkProject actorCurAndMaxSk+      calmE = calmEnough b actorCurAndMaxSk+  return $ permittedProject False skill calmE++projectCheck :: MonadClientUI m => ActorId -> Point -> m (Maybe ReqFailure)+projectCheck leader tpos = do+  COps{coTileSpeedup} <- getsState scops+  eps <- getsClient seps+  sb <- getsState $ getActorBody leader+  let lid = blid sb+      spos = bpos sb+  -- Not @ScreenContent@, because not drawing here.+  case bresenhamsLineAlgorithm eps spos tpos of+    Nothing -> return $ Just ProjectAimOnself+    Just [] -> error $ "project from the edge of level"+                       `showFailure` (spos, tpos, sb)+    Just (pos : _) -> do+      lvl <- getLevel lid+      let t = lvl `at` pos+      if not $ Tile.isWalkable coTileSpeedup t+        then return $ Just ProjectBlockTerrain+        else if occupiedBigLvl pos lvl+             then return $ Just ProjectBlockActor+             else return Nothing++-- | Check whether one is permitted to aim (for projecting) at a target.+-- The check is stricter for actor targets, assuming the player simply wants+-- to hit a single actor. In order to fine tune trick-shots, e.g., piercing+-- many actors, other aiming modes should be used.+-- Returns a different @seps@ if needed to reach the target.+--+-- Note: Simple Perception check is not enough for the check,+-- e.g., because the target actor can be obscured by a glass wall.+xhairLegalEps :: MonadClientUI m => ActorId -> m (Either Text Int)+xhairLegalEps leader = do+  cops@COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  b <- getsState $ getActorBody leader+  lidV <- viewedLevelUI+  let !_A = assert (lidV == blid b) ()+      findNewEps onlyFirst pos = do+        lvl <- getLevel (blid b)+        oldEps <- getsClient seps+        return $! case makeLine onlyFirst b pos oldEps cops lvl of+          Just newEps -> Right newEps+          Nothing -> Left $ if onlyFirst+                            then "aiming blocked at the first step"+                            else "aiming line blocked somewhere"+  xhair <- getsSession sxhair+  case xhair of+    Nothing -> return $ Left "no aim designated"+    Just (TEnemy a) -> do+      body <- getsState $ getActorBody a+      let pos = bpos body+      if blid body == lidV+      then findNewEps False pos+      else return $ Left "can't fling at an enemy on remote level"+    Just (TNonEnemy a) -> do+      body <- getsState $ getActorBody a+      let pos = bpos body+      if blid body == lidV+      then findNewEps False pos+      else return $ Left "can't fling at a non-enemy on remote level"+    Just (TPoint TEnemyPos{} _ _) ->+      return $ Left "selected opponent not visible"+    Just (TPoint _ lid pos) ->+      if lid == lidV+      then findNewEps True pos  -- @True@ to help pierce many foes, etc.+      else return $ Left "can't fling at a target on remote level"+    Just (TVector v) -> do+      -- Not @ScreenContent@, because not drawing here.+      let shifted = shiftBounded rWidthMax rHeightMax (bpos b) v+      if shifted == bpos b && v /= Vector 0 0+      then return $ Left "selected translation is void"+      else findNewEps True shifted  -- @True@, because the goal is vague anyway++posFromXhair :: (MonadClient m, MonadClientUI m)+             => ActorId -> m (Either Text Point)+posFromXhair leader = do+  canAim <- xhairLegalEps leader+  case canAim of+    Right newEps -> do+      -- Modify @seps@, permanently.+      modifyClient $ \cli -> cli {seps = newEps}+      mxhairPos <- mxhairToPos+      case mxhairPos of+        Nothing -> error $ "" `showFailure` mxhairPos+        Just pos -> do+          munit <- projectCheck leader pos+          case munit of+            Nothing -> return $ Right pos+            Just reqFail -> return $ Left $ showReqFailure reqFail+    Left cause -> return $ Left cause++-- | On top of `permittedProjectClient`, it also checks legality+-- of aiming at the target and projection range. It also modifies @eps@.+psuitReq :: (MonadClient m, MonadClientUI m)+         => ActorId+         -> m (Either Text (ItemFull -> Either ReqFailure (Point, Bool)))+psuitReq leader = do+  b <- getsState $ getActorBody leader+  lidV <- viewedLevelUI+  if lidV /= blid b+  then return $ Left "can't fling on remote level"+  else do+    mpos <- posFromXhair leader+    p <- permittedProjectClient leader+    case mpos of+      Left err -> return $ Left err+      Right pos -> return $ Right $ \itemFull ->+        case p itemFull of+          Left err -> Left err+          Right False -> Right (pos, False)+          Right True ->+            let arItem = aspectRecordFull itemFull+            in Right (pos, 1 + IA.totalRange arItem (itemKind itemFull)+                           >= chessDist (bpos b) pos)++-- $setup+-- >>> import Game.LambdaHack.Definition.DefsInternal++-- |+-- >>> let trigger1 = HumanCmd.TriggerItem{tiverb="verb", tiobject="object", tisymbols=[toContentSymbol 'a', toContentSymbol 'b']}+-- >>> let trigger2 = HumanCmd.TriggerItem{tiverb="verb2", tiobject="object2", tisymbols=[toContentSymbol 'c']}+-- >>> triggerSymbols [trigger1, trigger2]+-- "abc"+--+-- >>> triggerSymbols []+-- ""+triggerSymbols :: [HumanCmd.TriggerItem] -> [ContentSymbol IK.ItemKind]+triggerSymbols [] = []+triggerSymbols (HumanCmd.TriggerItem{tisymbols} : ts) =+  tisymbols ++ triggerSymbols ts++-- * ChooseItemApply++chooseItemApplyHuman :: forall m. MonadClientUI m+                     => ActorId -> [HumanCmd.TriggerItem] -> m MError+chooseItemApplyHuman leader ts = do+  b <- getsState $ getActorBody leader+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+  let overStash = mstash == Just (blid b, bpos b)+      storesBase = [CStash, CEqp, COrgan]+      stores | overStash = storesBase ++ [CGround]+             | otherwise = CGround : storesBase+      (verb1, object1) = case ts of+        [] -> ("trigger", "item")+        tr : _ -> (HumanCmd.tiverb tr, HumanCmd.tiobject tr)+      verb = makePhrase [verb1]+      triggerSyms = triggerSymbols ts+      prompt = makePhrase ["What", object1, "to"]+      promptGeneric = "What to"+  itemSel <- getsSession sitemSel+  case itemSel of+    Just (_, _, True) -> return Nothing+    Just (iid, fromCStore, False) -> do+      -- We don't validate vs @ts@ here, because player has selected+      -- this item, so he knows what he's doing (unless really absurd).+      itemFull <- getsState $ itemToFull iid+      bag <- getsState $ getBodyStoreBag b fromCStore+      mp <- permittedApplyClient leader+      case iid `EM.lookup` bag of+        Just kit | fromRight False (mp (Just fromCStore) itemFull kit) ->+          return Nothing+        _ -> do+          modifySession $ \sess -> sess {sitemSel = Nothing}+          chooseItemApplyHuman leader ts+    Nothing -> do+      let psuit :: m Suitability+          psuit = do+            mp <- permittedApplyClient leader+            return $ SuitsSomething $ \cstore itemFull kit ->+              fromRight False (mp cstore itemFull kit)+              && (null triggerSyms+                  || IK.isymbol (itemKind itemFull) `elem` triggerSyms)+      ggi <- getGroupItem leader psuit prompt promptGeneric verb "trigger"+                          stores+      case ggi of+        Right (fromCStore, iid) -> do+          modifySession $ \sess ->+            sess {sitemSel = Just (iid, fromCStore, False)}+          return Nothing+        Left err -> failMsg err++permittedApplyClient :: MonadClientUI m+                     => ActorId+                     -> m (Maybe CStore -> ItemFull -> ItemQuant+                           -> Either ReqFailure Bool)+permittedApplyClient leader = do+  COps{corule} <- getsState scops+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  b <- getsState $ getActorBody leader+  let skill = Ability.getSk Ability.SkApply actorCurAndMaxSk+      calmE = calmEnough b actorCurAndMaxSk+  localTime <- getsState $ getLocalTime (blid b)+  return $ permittedApply corule localTime skill calmE++-- * PickLeader++pickLeaderHuman :: MonadClientUI m => Int -> m MError+pickLeaderHuman k = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  arena <- getArenaUI+  sactorUI <- getsSession sactorUI+  mhero <- getsState $ tryFindHeroK sactorUI side k+  allOurs <- getsState $ fidActorNotProjGlobalAssocs side -- not only on level+  let allOursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) allOurs+      hs = sortOn keySelected allOursUI+      mactor = case drop k hs of+                 [] -> Nothing+                 (aid, b, _) : _ -> Just (aid, b)+      mchoice = if FK.fhasGender (gkind fact) then mhero else mactor+      banned = bannedPointmanSwitchBetweenLevels fact+  case mchoice of+    Nothing -> failMsg "no such member of the party"+    Just (aid, b)+      | blid b /= arena && banned ->+          failMsg $ showReqFailure NoChangeDunLeader+      | otherwise -> do+          void $ pickLeader True aid+          return Nothing++-- * PickLeaderWithPointer++pickLeaderWithPointerHuman :: MonadClientUI m => ActorId -> m MError+pickLeaderWithPointerHuman = pickLeaderWithPointer++-- * PointmanCycle++-- | Switch current pointman to the next on the viewed level, if any, wrapping.+pointmanCycleLevelHuman :: MonadClientUI m => ActorId -> Direction -> m MError+pointmanCycleLevelHuman leader = pointmanCycleLevel leader True++-- * PointmanBack++-- | Switch current pointman to the previous in the whole dungeon, wrapping.+pointmanCycleHuman :: MonadClientUI m => ActorId -> Direction -> m MError+pointmanCycleHuman leader = pointmanCycle leader True++-- * SelectActor++selectActorHuman :: MonadClientUI m => ActorId -> m ()+selectActorHuman leader = do+  bodyUI <- getsSession $ getActorUI leader+  wasMemeber <- getsSession $ ES.member leader . sselected+  let upd = if wasMemeber+            then ES.delete leader  -- already selected, deselect instead+            else ES.insert leader+  modifySession $ \sess -> sess {sselected = upd $ sselected sess}+  let subject = partActor bodyUI+  msgAdd MsgActionAlert $ makeSentence [subject, if wasMemeber+                                                 then "deselected"+                                                 else "selected"]++-- * SelectNone++selectNoneHuman :: MonadClientUI m => m ()+selectNoneHuman = do+  side <- getsClient sside+  lidV <- viewedLevelUI+  oursIds <- getsState $ fidActorRegularIds side lidV+  let ours = ES.fromDistinctAscList oursIds+  oldSel <- getsSession sselected+  let wasNone = ES.null $ ES.intersection ours oldSel+      upd = if wasNone+            then ES.union  -- already all deselected; select all instead+            else ES.difference+  modifySession $ \sess -> sess {sselected = upd (sselected sess) ours}+  let subject = "all party members on the level"+  msgAdd MsgActionAlert $ makeSentence [subject, if wasNone+                                                 then "selected"+                                                 else "deselected"]++-- * SelectWithPointer++selectWithPointerHuman :: MonadClientUI m => m MError+selectWithPointerHuman = do+  COps{corule=RuleContent{rHeightMax}} <- getsState scops+  lidV <- viewedLevelUI+  -- Not @ScreenContent@, because not drawing here.+  side <- getsClient sside+  ours <- getsState $ filter (not . bproj . snd)+                      . actorAssocs (== side) lidV+  sactorUI <- getsSession sactorUI+  let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours+      viewed = sortOn keySelected oursUI+  pUI <- getsSession spointer+  let p@(Point px py) = squareToMap $ uiToSquare pUI+  -- Select even if no space in status line for the actor's symbol.+  if | py == rHeightMax + 1 && px == 0 -> selectNoneHuman >> return Nothing+     | py == rHeightMax + 1 ->+         case drop (px - 1) viewed of+           [] -> failMsg "not pointing at an actor"+           (aid, _, _) : _ -> selectActorHuman aid >> return Nothing+     | otherwise ->+         case find (\(_, b) -> bpos b == p) ours of+           Nothing -> failMsg "not pointing at an actor"+           Just (aid, _) -> selectActorHuman aid >> return Nothing++-- * Repeat++-- Note that walk followed by repeat should not be equivalent to run,+-- because the player can really use a command that does not stop+-- at terrain change or when walking over items.+repeatHuman :: MonadClientUI m => Int -> m ()+repeatHuman n =+  modifySession $ \sess ->+    let (smacroFrameNew, smacroStackMew) =+           repeatHumanTransition n (smacroFrame sess) (smacroStack sess)+    in sess { smacroFrame = smacroFrameNew+            , smacroStack = smacroStackMew }++repeatHumanTransition :: Int -> KeyMacroFrame -> [KeyMacroFrame]+                      -> (KeyMacroFrame, [KeyMacroFrame])+repeatHumanTransition n macroFrame macroFrames =+  let kms = concat . replicate n . unKeyMacro . fromRight mempty+            $ keyMacroBuffer macroFrame+  in macroHumanTransition kms macroFrame macroFrames++-- * RepeatLast++-- Note that walk followed by repeat should not be equivalent to run,+-- because the player can really use a command that does not stop+-- at terrain change or when walking over items.+repeatLastHuman :: MonadClientUI m => Int -> m ()+repeatLastHuman n = modifySession $ \sess ->+  sess {smacroFrame = repeatLastHumanTransition n (smacroFrame sess) }++repeatLastHumanTransition :: Int -> KeyMacroFrame -> KeyMacroFrame+repeatLastHumanTransition n macroFrame =+  let macro = KeyMacro . concat . replicate n . maybeToList $ keyLast macroFrame+  in macroFrame { keyPending = macro <> keyPending macroFrame }++-- * Record++-- | Starts and stops recording of macros.+recordHuman :: MonadClientUI m => m ()+recordHuman = do+  smacroFrameOld <- getsSession smacroFrame+  let (smacroFrameNew, msg) = recordHumanTransition smacroFrameOld+  modifySession $ \sess -> sess {smacroFrame = smacroFrameNew}+  macroStack <- getsSession smacroStack+  unless (T.null msg || not (null macroStack)) $ msgAdd MsgPromptGeneric msg++recordHumanTransition :: KeyMacroFrame -> (KeyMacroFrame, Text)+recordHumanTransition macroFrame =+  let (buffer, msg) = case keyMacroBuffer macroFrame of+        Right _ ->+          -- Start recording in-game macro.+          (Left [], "Recording a macro. Stop recording with the same key.")+        Left xs ->+          -- Stop recording in-game macro.+          (Right . KeyMacro . reverse $ xs, "Macro recording stopped.")+      smacroFrameNew = macroFrame {keyMacroBuffer = buffer}+  in (smacroFrameNew, msg)++-- * AllHistory++allHistoryHuman :: forall m. MonadClientUI m => m ()+allHistoryHuman = do+  CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+  history <- getsSession shistory+  arena <- getArenaUI+  localTime <- getsState $ getLocalTime arena+  global <- getsState stime+  FontSetup{..} <- getFontSetup+  let renderedHistoryRaw = renderHistory history+      histLenRaw = length renderedHistoryRaw+      placeholderLine = textFgToAS Color.BrBlack+        "Newest_messages_are_at_the_bottom._Press_END_to_get_there."+      placeholderCount =+        (- histLenRaw `mod` (rheight - 4)) `mod` (rheight - 4)+      renderedHistory = replicate placeholderCount placeholderLine+                        ++ renderedHistoryRaw+      histLen = placeholderCount + histLenRaw+      splitRow as =+        let (tLab, tDesc) = span (/= Color.spaceAttrW32) as+            labLen = textSize monoFont tLab+            par1 = case filter (/= emptyAttrLine) $ linesAttr tDesc of+              [] -> emptyAttrLine+              [l] -> l+              ls -> attrStringToAL $ intercalate [Color.spaceAttrW32]+                                   $ map attrLine ls+        in (attrStringToAL tLab, (labLen, par1))+      (tsLab, tsDesc) = unzip $ map splitRow renderedHistory+      ovs = EM.insertWith (++) monoFont (offsetOverlay tsLab)+            $ EM.singleton propFont $ offsetOverlayX tsDesc+      turnsGlobal = global `timeFitUp` timeTurn+      turnsLocal = localTime `timeFitUp` timeTurn+      msg = makeSentence+        [ "You survived for"+        , MU.CarWs turnsGlobal "half-second turn"+        , "(this level:"+        , MU.Car turnsLocal <> ")" ]+      kxs = [ (Right sn, ( PointUI 0 (fromEnum sn)+                         , ButtonWidth propFont 1000 ))+            | sn <- take histLen natSlots ]+  msgAdd MsgPromptGeneric msg+  let keysAllHistory =+        K.returnKM+#ifndef USE_JSFILE+        : K.mkChar '.'+#endif+        : [K.spaceKM, K.escKM]+  slides <- overlayToSlideshow (rheight - 2) keysAllHistory (ovs, kxs)+  let historyLines = case reverse $ concatMap snd $ slideshow slides of+        (Left{}, _) : rest -> rest  -- don't count the @--more--@ line+        l -> l+      maxIx = length historyLines - 1 - length keysAllHistory+      menuName = "history"+  modifySession $ \sess ->+    sess {smenuIxMap = M.insert menuName maxIx $ smenuIxMap sess}+  let displayAllHistory = do+        ekm <- displayChoiceScreen menuName ColorFull False slides+                                   keysAllHistory+        case ekm of+          Left km | km == K.mkChar '.' -> do+            let t = T.unlines $ map (T.pack . map Color.charFromW32)+                                    renderedHistoryRaw+            path <- dumpTextFile t "history.txt"+            msgAdd MsgPromptGeneric $ "All of history dumped to file" <+> T.pack path <> "."+          Left km | km == K.escKM ->+            msgAdd MsgPromptGeneric "Try to survive a few seconds more, if you can."+          Left km | km == K.spaceKM ->+            msgAdd MsgPromptGeneric "Steady on."+          Left km | km == K.returnKM ->+            msgAdd MsgPromptGeneric "Press RET when history message selected to see it in full."+          Right slot ->+            displayOneReport $ toEnum $ max 0 $ fromEnum slot - placeholderCount+          _ -> error $ "" `showFailure` ekm+      displayOneReport :: MenuSlot -> m ()+      displayOneReport slot0 = do+        let renderOneItem slot = do+              let timeReport = case drop (fromEnum slot)+                                         renderedHistoryRaw of+                    [] -> error $ "" `showFailure` slot+                    tR : _ -> tR+                  markParagraph c | Color.charFromW32 c == '\n' = [c, c]+                  markParagraph c = [c]+                  reportWithParagraphs = concatMap markParagraph timeReport+                  (ovLab, ovDesc) =+                    labDescOverlay monoFont rwidth reportWithParagraphs+                  ov0 = EM.insertWith (++) monoFont ovLab+                        $ EM.singleton propFont ovDesc+                  prompt = makeSentence+                    [ "the", MU.Ordinal $ fromEnum slot + 1+                    , "most recent record follows" ]+              msgAdd MsgPromptGeneric prompt+              return (ov0, [])+            extraKeys = []+            slotBound = histLenRaw - 1+        km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0+        case K.key km of+          K.Space -> displayAllHistory+          K.Esc -> msgAdd MsgPromptGeneric+                          "Try to learn from your previous mistakes."+          _ -> error $ "" `showFailure` km+  displayAllHistory++-- * MarkVision++markVisionHuman :: MonadClientUI m => Int -> m ()+markVisionHuman delta = modifySession $ cycleMarkVision delta++-- * MarkSmell++markSmellHuman :: MonadClientUI m => m ()+markSmellHuman = modifySession toggleMarkSmell++-- * MarkSuspect++markSuspectHuman :: MonadClient m => Int -> m ()+markSuspectHuman delta = do+  -- @condBFS@ depends on the setting we change here.+  invalidateBfsAll+  modifyClient (cycleMarkSuspect delta)++-- * MarkAnim++markAnimHuman :: MonadClient m => m ()+markAnimHuman = do+  noAnim <- getsClient $ fromMaybe False . snoAnim . soptions+  modifyClient $ \cli ->+    cli {soptions = (soptions cli) {snoAnim = Just $ not noAnim}}++-- * OverrideTut++overrideTutHuman :: MonadClientUI m => Int -> m ()+overrideTutHuman delta = modifySession $ cycleOverrideTut delta++-- * PrintScreen++printScreenHuman :: MonadClientUI m => m ()+printScreenHuman = do+  msgAdd MsgActionAlert "Screenshot printed."+  printScreen++-- * Cancel++-- | End aiming mode, rejecting the current position, unless when on+-- remote level, in which case, return to our level.+cancelHuman :: MonadClientUI m => m ()+cancelHuman = do+  maimMode <- getsSession saimMode+  case maimMode of+    Just aimMode -> do+      let lidV = aimLevelId aimMode+      lidOur <- getArenaUI+      if lidV == lidOur+      then clearAimMode+      else do+        xhairPos <- xhairToPos+        let sxhair = Just $ TPoint TKnown lidOur xhairPos+        modifySession $ \sess ->+          sess {saimMode = Just aimMode {aimLevelId = lidOur}}+        setXHairFromGUI sxhair+        doLook+    Nothing -> return ()++-- * Accept++-- | Accept the current crosshair position as target, ending+-- aiming mode, if active.+acceptHuman :: (MonadClient m, MonadClientUI m) => ActorId -> m ()+acceptHuman leader = do+  endAiming leader+  endAimingMsg leader+  clearAimMode++-- | End aiming mode, accepting the current position.+endAiming :: (MonadClient m, MonadClientUI m) => ActorId -> m ()+endAiming leader = do+  sxhair <- getsSession sxhair+  modifyClient $ updateTarget leader $ const sxhair++endAimingMsg :: MonadClientUI m => ActorId -> m ()+endAimingMsg leader = do+  subject <- partActorLeader leader+  tgt <- getsClient $ getTarget leader+  (mtargetMsg, _) <- targetDesc tgt+  msgAdd MsgActionAlert $ case mtargetMsg of+    Nothing ->+      makeSentence [MU.SubjectVerbSg subject "clear target"]+    Just targetMsg ->+      makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]++-- * DetailCycle++-- | Cycle detail level of aiming mode descriptions, starting up.+detailCycleHuman :: MonadClientUI m => m ()+detailCycleHuman = do+  modifySession $ \sess -> sess {saimMode =+    (\aimMode -> aimMode {detailLevel = detailCycle $ detailLevel aimMode})+                 <$> saimMode sess}+  doLook++detailCycle :: DetailLevel -> DetailLevel+detailCycle detail = if detail == minBound then maxBound else pred detail++-- * ClearTargetIfItemClear++clearTargetIfItemClearHuman :: (MonadClient m, MonadClientUI m)+                            => ActorId -> m ()+clearTargetIfItemClearHuman leader = do+  itemSel <- getsSession sitemSel+  when (isNothing itemSel) $ do+    setXHairFromGUI Nothing+    modifyClient $ updateTarget leader (const Nothing)+    doLook++-- * ItemClear++itemClearHuman :: MonadClientUI m => m ()+itemClearHuman = modifySession $ \sess -> sess {sitemSel = Nothing}++-- * MoveXhair++-- | Move the xhair. Assumes aiming mode.+moveXhairHuman :: MonadClientUI m => Vector -> Int -> m MError+moveXhairHuman dir n = do+  -- Not @ScreenContent@, because not drawing here.+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  saimMode <- getsSession saimMode+  let lidV = maybe (error $ "" `showFailure` (dir, n)) aimLevelId saimMode+  xhair <- getsSession sxhair+  xhairPos <- xhairToPos+  let shiftB pos = shiftBounded rWidthMax rHeightMax pos dir+      newPos = iterate shiftB xhairPos !! n+  if newPos == xhairPos then failMsg "never mind"+  else do+    mleader <- getsClient sleader+    sxhair <- case (xhair, mleader) of+     (Just TVector{}, Just leader) -> do+       lpos <- getsState $ bpos . getActorBody leader+       return $ Just $ TVector $ newPos `vectorToFrom` lpos+     _ -> return $ Just $ TPoint TKnown lidV newPos+    setXHairFromGUI sxhair+    doLook+    return Nothing++-- * AimTgt++-- | Start aiming.+aimTgtHuman :: MonadClientUI m => m ()+aimTgtHuman = do+  -- (Re)start aiming at the current level.+  lidV <- viewedLevelUI+  modifySession $ \sess -> sess {saimMode =+    let newDetail = maybe defaultDetailLevel detailLevel (saimMode sess)+    in Just $ AimMode lidV newDetail}+  doLook+  msgAdd MsgPromptAction "*flinging started; press again to project*"++-- * AimFloor++-- | Cycle aiming mode. Do not change position of the xhair,+-- switch target to point at different things at that position.+aimFloorHuman :: MonadClientUI m => m ()+aimFloorHuman = do+  lidV <- viewedLevelUI+  mleader <- getsClient sleader+  mlpos <- case mleader of+    Nothing -> return Nothing+    Just leader -> getsState $ Just . bpos . getActorBody leader+  xhairPos <- xhairToPos+  xhair <- getsSession sxhair+  saimMode <- getsSession saimMode+  bsAll <- getsState $ actorAssocs (const True) lidV+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let sxhair = case xhair of+        _ | isNothing saimMode ->  -- first key press: keep target+          xhair+        Just TEnemy{} -> Just $ TPoint TKnown lidV xhairPos+        Just TNonEnemy{} -> Just $ TPoint TKnown lidV xhairPos+        Just TPoint{} | Just lpos <- mlpos, xhairPos /= lpos ->+          Just $ TVector $ xhairPos `vectorToFrom` lpos+        Just TVector{} ->+          -- If many actors, we pick here the first that would be picked+          -- by '*', so that all other projectiles on the tile come next,+          -- when pressing '*', without any intervening actors from other tiles.+          -- This is why we use @actorAssocs@ above instead of @posToAidAssocs@.+          case find (\(_, b) -> bpos b == xhairPos) bsAll of+            Just (aid, b) -> Just $ if isFoe side fact (bfid b)+                                    then TEnemy aid+                                    else TNonEnemy aid+            Nothing -> Just $ TPoint TUnknown lidV xhairPos+        _ -> xhair+  modifySession $ \sess -> sess {saimMode =+    let newDetail = maybe defaultDetailLevel detailLevel saimMode+    in Just $ AimMode lidV newDetail}+  setXHairFromGUI sxhair+  doLook++-- * AimEnemy++aimEnemyHuman :: MonadClientUI m => m ()+aimEnemyHuman = do+  lidV <- viewedLevelUI+  mleader <- getsClient sleader+  mlpos <- case mleader of+    Nothing -> return Nothing+    Just leader -> getsState $ Just . bpos . getActorBody leader+  mxhairPos <- mxhairToPos+  xhair <- getsSession sxhair+  saimMode <- getsSession saimMode+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  bsAll <- getsState $ actorAssocs (const True) lidV+  let -- On the same position, big actors come before projectiles.+      ordPos lpos (_, b) = (chessDist lpos $ bpos b, bpos b, bproj b)+      dbs = case mlpos of+        Nothing -> bsAll+        Just lpos -> sortOn (ordPos lpos) bsAll+      pickUnderXhair =  -- switch to the actor under xhair, if any+        fromMaybe (-1) $ findIndex ((== mxhairPos) . Just . bpos . snd) dbs+      (pickEnemies, i) = case xhair of+        Just (TEnemy a) | isJust saimMode ->  -- pick next enemy+          (True, 1 + fromMaybe (-1) (findIndex ((== a) . fst) dbs))+        Just (TEnemy a) ->  -- first key press, retarget old enemy+          (True, fromMaybe (-1) $ findIndex ((== a) . fst) dbs)+        Just (TNonEnemy a) | isJust saimMode ->  -- pick next non-enemy+          (False, 1 + fromMaybe (-1) (findIndex ((== a) . fst) dbs))+        Just (TNonEnemy a) ->  -- first key press, retarget old non-enemy+          (False, fromMaybe (-1) $ findIndex ((== a) . fst) dbs)+        _ -> (True, pickUnderXhair)+      (lt, gt) = splitAt i dbs+      isEnemy b = isFoe side fact (bfid b)+                  && not (bproj b)+                  && bhp b > 0+      cond = if pickEnemies then isEnemy else not . isEnemy+      lf = filter (cond . snd) $ gt ++ lt+      sxhair = case lf of+        (a, _) : _ -> Just $ if pickEnemies then TEnemy a else TNonEnemy a+        [] -> xhair  -- no seen foes in sight, stick to last target+  -- Register the chosen enemy, to pick another on next invocation.+  modifySession $ \sess -> sess {saimMode =+    let newDetail = maybe defaultDetailLevel detailLevel saimMode+    in Just $ AimMode lidV newDetail}+  setXHairFromGUI sxhair+  doLook++-- * AimItem++aimItemHuman :: MonadClientUI m => m ()+aimItemHuman = do+  side <- getsClient sside+  lidV <- viewedLevelUI+  mleader <- getsClient sleader+  mlpos <- case mleader of+    Nothing -> return Nothing+    Just leader -> getsState $ Just . bpos . getActorBody leader+  mxhairPos <- mxhairToPos+  xhair <- getsSession sxhair+  saimMode <- getsSession saimMode+  Level{lfloor} <- getLevel lidV+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! side+  -- Don't consider own stash an ordinary pile of items.+  let lfloorBarStash = case mstash of+        Just (lid, pos) | lid == lidV -> EM.delete pos lfloor+        _ -> lfloor+      bsAll = EM.keys lfloorBarStash+      ordPos lpos p = (chessDist lpos p, p)+      dbs = case mlpos of+        Nothing -> bsAll+        Just lpos -> sortOn (ordPos lpos) bsAll+      pickUnderXhair =  -- switch to the item under xhair, if any+        let i = fromMaybe (-1)+                $ findIndex ((== mxhairPos) . Just) dbs+        in splitAt i dbs+      (lt, gt) = case xhair of+        Just (TPoint _ lid pos)+          | isJust saimMode && lid == lidV ->  -- pick next item+            let i = fromMaybe (-1) $ elemIndex pos dbs+            in splitAt (i + 1) dbs+        Just (TPoint _ lid pos)+          | lid == lidV ->  -- first key press, retarget old item+            let i = fromMaybe (-1) $ elemIndex pos dbs+            in splitAt i dbs+        _ -> pickUnderXhair+      gtlt = gt ++ lt+      sxhair = case gtlt of+        p : _ -> Just $ TPoint TKnown lidV p  -- don't force AI to collect it+        [] -> xhair  -- no items remembered, stick to last target+  -- Register the chosen enemy, to pick another on next invocation.+  modifySession $ \sess -> sess {saimMode =+    let newDetail = maybe defaultDetailLevel detailLevel saimMode+    in Just $ AimMode lidV newDetail}+  setXHairFromGUI sxhair+  doLook++-- * AimAscend++-- | Change the displayed level in aiming mode to (at most)+-- k levels shallower. Enters aiming mode, if not already in one.+aimAscendHuman :: MonadClientUI m => Int -> m MError+aimAscendHuman k = do+  dungeon <- getsState sdungeon+  lidV <- viewedLevelUI+  let up = k > 0+  case ascendInBranch dungeon up lidV of+    [] -> failMsg "no more levels in this direction"+    _ : _ -> do+      let ascendOne lid = case ascendInBranch dungeon up lid of+            [] -> lid+            nlid : _ -> nlid+          lidK = iterate ascendOne lidV !! abs k+      xhairPos <- xhairToPos+      let sxhair = Just $ TPoint TKnown lidK xhairPos+      modifySession $ \sess -> sess {saimMode =+        let newDetail = maybe defaultDetailLevel detailLevel (saimMode sess)+        in Just $ AimMode lidK newDetail}+      setXHairFromGUI sxhair+      doLook+      return Nothing++-- * EpsIncr++-- | Tweak the @eps@ parameter of the aiming digital line.+epsIncrHuman :: (MonadClient m, MonadClientUI m) => Direction -> m ()+epsIncrHuman d = do+  -- Perform the change:+  let sepsDelta = case d of+        Forward -> 1+        Backward -> -1+  modifyClient $ \cli -> cli {seps = seps cli + sepsDelta}+  invalidateBfsPathAll+  -- Provide UI feedback:+  -- Hack @sreportNull@ to display the new line even if no earlier messages.+  modifySession $ \sess -> sess {sreportNull = False}+  saimMode <- getsSession saimMode+  lidV <- viewedLevelUI+  modifySession $ \sess -> sess {saimMode =+    let newDetail = maybe DetailLow detailLevel saimMode+    in Just $ AimMode lidV newDetail}+  flashAiming+  modifySession $ \sess -> sess {saimMode}+  -- The change may not affect the line shape, hence 'possibly'.+  msgAdd MsgPromptAction "Aiming line (possibly) modified."++-- Flash the aiming line and path.+flashAiming :: MonadClientUI m => m ()+flashAiming = do+  lidV <- viewedLevelUI+  animate lidV pushAndDelay++-- * XhairUnknown++xhairUnknownHuman :: (MonadClient m, MonadClientUI m) => ActorId -> m MError+xhairUnknownHuman leader = do+  b <- getsState $ getActorBody leader+  mpos <- closestUnknown leader+  case mpos of+    Nothing -> failMsg "no more unknown spots left"+    Just p -> do+      let sxhair = Just $ TPoint TUnknown (blid b) p+      setXHairFromGUI sxhair+      doLook+      return Nothing++-- * XhairItem++xhairItemHuman :: (MonadClient m, MonadClientUI m) => ActorId -> m MError+xhairItemHuman leader = do+  b <- getsState $ getActorBody leader+  items <- closestItems leader+  case items of+    [] -> failMsg "no more reachable items remembered or visible"+    _ -> do+      let (_, (p, bag)) = maximumBy (comparing fst) items+          sxhair = Just $ TPoint (TItem bag) (blid b) p+      setXHairFromGUI sxhair+      doLook+      return Nothing++-- * XhairStair++xhairStairHuman :: (MonadClient m, MonadClientUI m)+                => ActorId -> Bool -> m MError+xhairStairHuman leader up = do+  b <- getsState $ getActorBody leader+  stairs <- closestTriggers (if up then ViaStairsUp else ViaStairsDown) leader+  case stairs of+    [] -> failMsg $ "no reachable stairs" <+> if up then "up" else "down"+    _ -> do+      let (_, (p, (p0, bag))) = maximumBy (comparing fst) stairs+          sxhair = Just $ TPoint (TEmbed bag p0) (blid b) p+      setXHairFromGUI sxhair+      doLook+      return Nothing++-- * XhairPointerFloor++xhairPointerFloorHuman :: MonadClientUI m => m ()+xhairPointerFloorHuman = do+  saimMode <- getsSession saimMode+  aimPointerFloorHuman+  when (isNothing saimMode) $+    modifySession $ \sess -> sess {saimMode}++-- * XhairPointerMute++xhairPointerMuteHuman :: MonadClientUI m => m ()+xhairPointerMuteHuman = do+  saimMode <- getsSession saimMode+  aimPointerFloorLoud False+  when (isNothing saimMode) $+    modifySession $ \sess -> sess {saimMode}++-- * XhairPointerEnemy++xhairPointerEnemyHuman :: MonadClientUI m => m ()+xhairPointerEnemyHuman = do+  saimMode <- getsSession saimMode+  aimPointerEnemyHuman+  when (isNothing saimMode) $+    modifySession $ \sess -> sess {saimMode}++-- * AimPointerFloor++aimPointerFloorHuman :: MonadClientUI m => m ()+aimPointerFloorHuman = aimPointerFloorLoud True++aimPointerFloorLoud :: MonadClientUI m => Bool -> m ()+aimPointerFloorLoud loud = do+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  lidV <- viewedLevelUI+  -- Not @ScreenContent@, because not drawing here.+  pUI <- getsSession spointer+  let p = squareToMap $ uiToSquare pUI+  if insideP (0, 0, rWidthMax - 1, rHeightMax - 1) p+  then do+    oldXhair <- getsSession sxhair+    let sxhair = Just $ TPoint TUnknown lidV p+        sxhairMoused = sxhair /= oldXhair+        detailSucc = if sxhairMoused+                     then detailLevel+                     else detailCycle . detailLevel+    modifySession $ \sess ->+      sess { saimMode =+               let newDetail = maybe defaultDetailLevel detailSucc+                                     (saimMode sess)+               in Just $ AimMode lidV newDetail+           , sxhairMoused }+    setXHairFromGUI sxhair+    when loud doLook+  else stopPlayBack++-- * AimPointerEnemy++aimPointerEnemyHuman :: MonadClientUI m => m ()+aimPointerEnemyHuman = do+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  lidV <- viewedLevelUI+  -- Not @ScreenContent@, because not drawing here.+  pUI <- getsSession spointer+  let p = squareToMap $ uiToSquare pUI+  if insideP (0, 0, rWidthMax - 1, rHeightMax - 1) p+  then do+    bsAll <- getsState $ actorAssocs (const True) lidV+    oldXhair <- getsSession sxhair+    side <- getsClient sside+    fact <- getsState $ (EM.! side) . sfactionD+    let sxhair =+          -- If many actors, we pick here the first that would be picked+          -- by '*', so that all other projectiles on the tile come next,+          -- when pressing '*', without any intervening actors from other tiles.+          -- This is why we use @actorAssocs@ above instead of @posToAidAssocs@.+          case find (\(_, b) -> bpos b == p) bsAll of+            Just (aid, b) -> Just $ if isFoe side fact (bfid b)+                                    then TEnemy aid+                                    else TNonEnemy aid+            Nothing -> Just $ TPoint TUnknown lidV p+        sxhairMoused = sxhair /= oldXhair+        detailSucc = if sxhairMoused+                     then detailLevel+                     else detailCycle . detailLevel+    modifySession $ \sess ->+      sess { saimMode =+               let newDetail = maybe defaultDetailLevel detailSucc+                                     (saimMode sess)+               in Just $ AimMode lidV newDetail+           , sxhairMoused }+    setXHairFromGUI sxhair+    doLook+  else stopPlayBack
+ engine-src/Game/LambdaHack/Client/UI/HandleHumanM.hs view
@@ -0,0 +1,225 @@+-- | Semantics of human player commands.+module Game.LambdaHack.Client.UI.HandleHumanM+  ( cmdSemInCxtOfKM, updateKeyLast+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , noRemoteHumanCmd, CmdLeaderNeed, cmdSemantics, cmdSemanticsLeader+  , addNoError, addLeader, weaveLeader+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.HandleHumanGlobalM+import           Game.LambdaHack.Client.UI.HandleHumanLocalM+import           Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Common.Types++-- | Commands that are forbidden on a remote level, because they+-- would usually take time when invoked on one, but not necessarily do+-- what the player expects. Note that some commands that normally take time+-- are not included, because they don't take time in aiming mode+-- or their individual sanity conditions include a remote level check.+noRemoteHumanCmd :: HumanCmd -> Bool+noRemoteHumanCmd cmd = case cmd of+  Wait          -> True+  Wait10        -> True+  MoveItem{}    -> True+  Apply{}       -> True+  AlterDir{}    -> True+  AlterWithPointer{} -> True+  MoveOnceToXhair -> True+  RunOnceToXhair -> True+  ContinueToXhair -> True+  _ -> False++updateKeyLast :: K.KM -> HumanCmd -> KeyMacroFrame -> KeyMacroFrame+updateKeyLast km cmd macroFrame = case cmd of+  RepeatLast{} -> macroFrame+  Record{} -> macroFrame+  _ -> macroFrame {keyLast = Just km}++-- | The semantics of human player commands in terms of the client monad,+-- in context of the given @km@ as the last action.+--+-- Some time cosuming commands are enabled even in aiming mode, but cannot be+-- invoked in aiming mode on a remote level (level different than+-- the level of the leader). Commands that require a pointman fail+-- when no leader is designated.+cmdSemInCxtOfKM :: (MonadClient m, MonadClientUI m)+                => K.KM -> HumanCmd -> m (Either MError ReqUI)+cmdSemInCxtOfKM km cmd = do+  modifySession $ \sess ->+    sess {smacroFrame = updateKeyLast km cmd $ smacroFrame sess}+  cmdSemantics cmd++data CmdLeaderNeed m =+    CmdNoNeed (m (Either MError ReqUI))+  | CmdLeader (ActorId -> m (Either MError ReqUI))++cmdSemantics :: (MonadClient m, MonadClientUI m)+             => HumanCmd -> m (Either MError ReqUI)+cmdSemantics cmd = case cmdSemanticsLeader cmd of+  CmdNoNeed mreq -> mreq+  CmdLeader f -> do+    mleader <- getsClient sleader+    case mleader of+      Nothing -> weaveJust <$> failWith+        "command disabled when no pointman designated, choose another command"+      Just leader -> do+        if noRemoteHumanCmd cmd then do+          -- If in aiming mode, check if the current level is the same+          -- as player level and refuse performing the action otherwise.+          arena <- getArenaUI+          lidV <- viewedLevelUI+          if arena /= lidV then+            weaveJust <$> failWith+              "command disabled on a remote level, press ESC to switch back"+          else f leader+        else f leader++cmdSemanticsLeader :: (MonadClient m, MonadClientUI m)+                   => HumanCmd -> CmdLeaderNeed m+cmdSemanticsLeader cmd = case cmd of+  Macro kms -> addNoError $ macroHuman kms+  ByArea l -> CmdNoNeed $ byAreaHuman cmdSemInCxtOfKM l+  ByAimMode AimModeCmd{..} ->+    CmdNoNeed $ byAimModeHuman (cmdSemantics exploration) (cmdSemantics aiming)+  ComposeIfLocal cmd1 cmd2 ->+    CmdNoNeed $ composeIfLocalHuman (cmdSemantics cmd1) (cmdSemantics cmd2)+  ComposeUnlessError cmd1 cmd2 ->+    CmdNoNeed $ composeUnlessErrorHuman (cmdSemantics cmd1) (cmdSemantics cmd2)+  Compose2ndLocal cmd1 cmd2 ->+    CmdNoNeed $ compose2ndLocalHuman (cmdSemantics cmd1) (cmdSemantics cmd2)+  LoopOnNothing cmd1 -> CmdNoNeed $ loopOnNothingHuman (cmdSemantics cmd1)+  ExecuteIfClear cmd1 -> CmdNoNeed $ executeIfClearHuman (cmdSemantics cmd1)++  Wait -> weaveLeader $ \leader -> ReqUITimed <$$> waitHuman leader+  Wait10 -> weaveLeader $ \leader -> ReqUITimed <$$> waitHuman10 leader+  Yell -> weaveLeader $ \leader -> ReqUITimed <$$> yellHuman leader+  MoveDir v -> weaveLeader $ \leader ->+                 ReqUITimed <$$> moveRunHuman leader True True False False v+  RunDir v -> weaveLeader $ \leader ->+                ReqUITimed <$$> moveRunHuman leader True True True True v+  RunOnceAhead ->+    CmdLeader $ \leader -> ReqUITimed <$$> runOnceAheadHuman leader+  MoveOnceToXhair -> weaveLeader $ \leader ->+                       ReqUITimed <$$> moveOnceToXhairHuman leader+  RunOnceToXhair  -> weaveLeader $ \leader ->+                       ReqUITimed <$$> runOnceToXhairHuman leader+  ContinueToXhair -> weaveLeader $ \leader ->+                       ReqUITimed <$$> continueToXhairHuman leader+  MoveItem stores toCStore mverb auto ->+    weaveLeader $ \leader ->+      ReqUITimed <$$> moveItemHuman leader stores toCStore mverb auto+  Project -> weaveLeader $ \leader -> ReqUITimed <$$> projectHuman leader+  Apply -> weaveLeader $ \leader -> ReqUITimed <$$> applyHuman leader+  AlterDir -> weaveLeader $ \leader -> ReqUITimed <$$> alterDirHuman leader+  AlterWithPointer ->+    weaveLeader $ \leader -> ReqUITimed <$$> alterWithPointerHuman leader+  CloseDir -> weaveLeader $ \leader -> ReqUITimed <$$> closeDirHuman leader+  Help -> CmdNoNeed $ helpHuman cmdSemInCxtOfKM+  Hint -> CmdNoNeed $ hintHuman cmdSemInCxtOfKM+  ItemMenu -> CmdLeader $ \leader -> itemMenuHuman leader cmdSemInCxtOfKM+  ChooseItemMenu dialogMode ->+    CmdLeader $ \leader -> chooseItemMenuHuman leader cmdSemInCxtOfKM dialogMode+  MainMenu -> CmdNoNeed $ mainMenuHuman cmdSemInCxtOfKM+  MainMenuAutoOn -> CmdNoNeed $ mainMenuAutoOnHuman cmdSemInCxtOfKM+  MainMenuAutoOff -> CmdNoNeed $ mainMenuAutoOffHuman cmdSemInCxtOfKM+  Dashboard -> CmdNoNeed $ dashboardHuman cmdSemInCxtOfKM+  GameDifficultyIncr delta ->+    CmdNoNeed $ gameDifficultyIncr delta >> challengeMenuHuman cmdSemInCxtOfKM+  GameFishToggle ->+    CmdNoNeed $ gameFishToggle >> challengeMenuHuman cmdSemInCxtOfKM+  GameGoodsToggle ->+    CmdNoNeed $ gameGoodsToggle >> challengeMenuHuman cmdSemInCxtOfKM+  GameWolfToggle ->+    CmdNoNeed $ gameWolfToggle >> challengeMenuHuman cmdSemInCxtOfKM+  GameKeeperToggle ->+    CmdNoNeed $ gameKeeperToggle >> challengeMenuHuman cmdSemInCxtOfKM+  GameScenarioIncr delta ->+    CmdNoNeed $ gameScenarioIncr delta >> challengeMenuHuman cmdSemInCxtOfKM++  GameRestart -> CmdNoNeed $ weaveJust <$> gameExitWithHuman Restart+  GameQuit -> CmdNoNeed $ weaveJust <$> gameExitWithHuman Quit+  GameDrop -> CmdNoNeed $ weaveJust <$> fmap Right gameDropHuman+  GameExit -> CmdNoNeed $ weaveJust <$> fmap Right gameExitHuman+  GameSave -> CmdNoNeed $ weaveJust <$> fmap Right gameSaveHuman+  Doctrine -> CmdNoNeed $ weaveJust <$> doctrineHuman+  Automate -> CmdNoNeed $ weaveJust <$> automateHuman+  AutomateToggle -> CmdNoNeed $ weaveJust <$> automateToggleHuman+  AutomateBack -> CmdNoNeed automateBackHuman++  ChooseItem dialogMode ->+    CmdLeader $ \leader -> Left <$> chooseItemHuman leader dialogMode+  ChooseItemProject ts ->+    CmdLeader $ \leader -> Left <$> chooseItemProjectHuman leader ts+  ChooseItemApply ts ->+    CmdLeader $ \leader -> Left <$> chooseItemApplyHuman leader ts+  PickLeader k -> CmdNoNeed $ Left <$> pickLeaderHuman k+  PickLeaderWithPointer ->+    CmdLeader $ fmap Left . pickLeaderWithPointerHuman+  PointmanCycle direction ->+    CmdLeader $ \leader -> Left <$> pointmanCycleHuman leader direction+  PointmanCycleLevel direction ->+    CmdLeader $ \leader -> Left <$> pointmanCycleLevelHuman leader direction+  SelectActor -> addLeader selectActorHuman+  SelectNone -> addNoError selectNoneHuman+  SelectWithPointer -> CmdNoNeed $ Left <$> selectWithPointerHuman+  Repeat n -> addNoError $ repeatHuman n+  RepeatLast n -> addNoError $ repeatLastHuman n+  Record -> addNoError recordHuman+  AllHistory -> addNoError allHistoryHuman+  MarkVision delta ->+    CmdNoNeed $ markVisionHuman delta >> settingsMenuHuman cmdSemInCxtOfKM+  MarkSmell ->+    CmdNoNeed $ markSmellHuman >> settingsMenuHuman cmdSemInCxtOfKM+  MarkSuspect delta ->+    CmdNoNeed $ markSuspectHuman delta >> settingsMenuHuman cmdSemInCxtOfKM+  MarkAnim ->+    CmdNoNeed $ markAnimHuman >> settingsMenuHuman cmdSemInCxtOfKM+  OverrideTut delta ->+    CmdNoNeed $ overrideTutHuman delta >> settingsMenuHuman cmdSemInCxtOfKM+  SettingsMenu -> CmdNoNeed $ settingsMenuHuman cmdSemInCxtOfKM+  ChallengeMenu -> CmdNoNeed $ challengeMenuHuman cmdSemInCxtOfKM+  PrintScreen -> addNoError printScreenHuman++  Cancel -> addNoError cancelHuman+  Accept -> addLeader acceptHuman+  DetailCycle -> addNoError detailCycleHuman+  ClearTargetIfItemClear -> addLeader clearTargetIfItemClearHuman+  ItemClear -> addNoError itemClearHuman+  MoveXhair v k -> CmdNoNeed $ Left <$> moveXhairHuman v k+  AimTgt -> addNoError aimTgtHuman+  AimFloor -> addNoError aimFloorHuman+  AimEnemy -> addNoError aimEnemyHuman+  AimItem -> addNoError aimItemHuman+  AimAscend k -> CmdNoNeed $ Left <$> aimAscendHuman k+  EpsIncr b -> addNoError $ epsIncrHuman b+  XhairUnknown -> CmdLeader $ fmap Left . xhairUnknownHuman+  XhairItem -> CmdLeader $ fmap Left . xhairItemHuman+  XhairStair up -> CmdLeader $ \leader -> Left <$> xhairStairHuman leader up+  XhairPointerFloor -> addNoError xhairPointerFloorHuman+  XhairPointerMute -> addNoError xhairPointerMuteHuman+  XhairPointerEnemy -> addNoError xhairPointerEnemyHuman+  AimPointerFloor -> addNoError aimPointerFloorHuman+  AimPointerEnemy -> addNoError aimPointerEnemyHuman++addNoError :: Monad m => m () -> CmdLeaderNeed m+addNoError cmdCli = CmdNoNeed $ cmdCli >> return (Left Nothing)++addLeader :: Monad m => (ActorId -> m ()) -> CmdLeaderNeed m+addLeader cmdCli =+  CmdLeader $ \leader -> cmdCli leader >> return (Left Nothing)++weaveLeader :: Monad m => (ActorId -> m (FailOrCmd ReqUI)) -> CmdLeaderNeed m+weaveLeader cmdCli = CmdLeader $ fmap weaveJust . cmdCli
+ engine-src/Game/LambdaHack/Client/UI/HumanCmd.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Abstract syntax of human player commands.+module Game.LambdaHack.Client.UI.HumanCmd+  ( CmdCategory(..), categoryDescription+  , CmdArea(..), areaDescription+  , CmdTriple, AimModeCmd(..), HumanCmd(..)+  , TriggerItem(..)+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.DeepSeq+import           Data.Binary+import           GHC.Generics (Generic)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind (ItemKind)+import Game.LambdaHack.Definition.Defs++data CmdCategory =+    CmdDashboard | CmdItemMenu+  | CmdMove | CmdItem | CmdAim | CmdMeta | CmdMouse+  | CmdInternal | CmdDebug | CmdMinimal+  deriving (Show, Read, Eq, Generic)++instance NFData CmdCategory++instance Binary CmdCategory++categoryDescription :: CmdCategory -> Text+categoryDescription CmdDashboard = "Dashboard"+categoryDescription CmdItemMenu = "Item menu commands"+categoryDescription CmdMove = "Terrain exploration and modification commands"+categoryDescription CmdItem = "All item-related commands"+categoryDescription CmdAim = "All aiming commands"+categoryDescription CmdMeta = "Assorted commands"+categoryDescription CmdMouse = "Mouse"+categoryDescription CmdInternal = "Internal"+categoryDescription CmdDebug = "Debug"+categoryDescription CmdMinimal = "The minimal command set"++-- The constructors are sorted, roughly, wrt inclusion, then top to bottom,+-- the left to right.+-- | Symbolic representation of areas of the screen used to define the meaning+-- of mouse button presses relative to where the mouse points to.+data CmdArea =+    CaMessage+  | CaMapLeader+  | CaMapParty+  | CaMap+  | CaLevelNumber+  | CaArenaName+  | CaPercentSeen+  | CaXhairDesc+  | CaSelected+  | CaCalmGauge+  | CaCalmValue+  | CaHPGauge+  | CaHPValue+  | CaLeaderDesc+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData CmdArea++instance Binary CmdArea++areaDescription :: CmdArea -> Text+areaDescription ca = case ca of+  CaMessage ->      "message line"+  CaMapLeader ->    "pointman tile"+  CaMapParty ->     "party on map"+  CaMap ->          "the map area"+  CaLevelNumber ->  "level number"+  CaArenaName ->    "level caption"+  CaPercentSeen ->  "percent seen"+  CaXhairDesc ->    "crosshair info"+  CaSelected ->     "party roster"+  CaCalmGauge ->    "Calm gauge"+  CaCalmValue ->    "Calm value"+  CaHPGauge ->      "HP gauge"+  CaHPValue ->      "HP value"+  CaLeaderDesc ->   "pointman info"+  --                 1234567890123++-- | This triple of command categories, description and the command term itself+-- defines the meaning of a human command as entered via a keypress,+-- mouse click or chosen from a menu.+type CmdTriple = ([CmdCategory], Text, HumanCmd)++data AimModeCmd = AimModeCmd {exploration :: HumanCmd, aiming :: HumanCmd}+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData AimModeCmd++instance Binary AimModeCmd++-- | Abstract syntax of human player commands.+data HumanCmd =+    -- Meta.+    Macro [String]+  | ByArea [(CmdArea, HumanCmd)]  -- if outside the areas, do nothing+  | ByAimMode AimModeCmd+  | ComposeIfLocal HumanCmd HumanCmd+  | ComposeUnlessError HumanCmd HumanCmd+  | Compose2ndLocal HumanCmd HumanCmd+  | LoopOnNothing HumanCmd+  | ExecuteIfClear HumanCmd+    -- Global.+    -- These usually take time.+  | Wait+  | Wait10+  | Yell+  | MoveDir Vector+  | RunDir Vector+  | RunOnceAhead+  | MoveOnceToXhair+  | RunOnceToXhair+  | ContinueToXhair+  | MoveItem [CStore] CStore (Maybe Text) Bool+  | Project+  | Apply+  | AlterDir+  | AlterWithPointer+  | CloseDir+  | Help+  | Hint+  | ItemMenu+  | MainMenu+  | MainMenuAutoOn+  | MainMenuAutoOff+  | Dashboard+    -- Below this line, commands do not take time.+  | GameDifficultyIncr Int+  | GameFishToggle+  | GameGoodsToggle+  | GameWolfToggle+  | GameKeeperToggle+  | GameScenarioIncr Int+  | GameRestart+  | GameQuit+  | GameDrop+  | GameExit+  | GameSave+  | Doctrine+  | Automate+  | AutomateToggle+  | AutomateBack+    -- Local. Below this line, commands do not notify the server.+  | ChooseItem ItemDialogMode+  | ChooseItemMenu ItemDialogMode+  | ChooseItemProject [TriggerItem]+  | ChooseItemApply [TriggerItem]+  | PickLeader Int+  | PickLeaderWithPointer+  | PointmanCycle Direction+  | PointmanCycleLevel Direction+  | SelectActor+  | SelectNone+  | SelectWithPointer+  | Repeat Int+  | RepeatLast Int+  | Record+  | AllHistory+  | MarkVision Int+  | MarkSmell+  | MarkSuspect Int+  | MarkAnim+  | OverrideTut Int+  | SettingsMenu+  | ChallengeMenu+  | PrintScreen+    -- These are mostly related to aiming.+  | Cancel+  | Accept+  | DetailCycle+  | ClearTargetIfItemClear+  | ItemClear+  | MoveXhair Vector Int+  | AimTgt+  | AimFloor+  | AimEnemy+  | AimItem+  | AimAscend Int+  | EpsIncr Direction+  | XhairUnknown+  | XhairItem+  | XhairStair Bool+  | XhairPointerFloor+  | XhairPointerMute+  | XhairPointerEnemy+  | AimPointerFloor+  | AimPointerEnemy+  deriving (Show, Read, Eq, Ord, Generic)++instance NFData HumanCmd++instance Binary HumanCmd++-- | Description of how item manipulation is triggered and communicated+-- to the player.+data TriggerItem =+  TriggerItem {tiverb :: MU.Part, tiobject :: MU.Part, tisymbols :: [ContentSymbol ItemKind]}+  deriving (Show, Eq, Ord, Generic)++instance Read TriggerItem where+  readsPrec = error $ "parsing of TriggerItem not implemented" `showFailure` ()++instance NFData TriggerItem++instance Binary TriggerItem
+ engine-src/Game/LambdaHack/Client/UI/InventoryM.hs view
@@ -0,0 +1,783 @@+-- | UI of inventory management.+module Game.LambdaHack.Client.UI.InventoryM+  ( Suitability(..), ResultItemDialogMode(..)+  , getFull, getGroupItem, getStoreItem+  , skillCloseUp, placeCloseUp, factionCloseUp+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , ItemDialogState(..), accessModeBag, storeItemPrompt, getItem+  , DefItemKey(..), transition+  , runDefMessage, runDefAction, runDefSkills, skillsInRightPane+  , runDefPlaces, placesInRightPane+  , runDefFactions, factionsInRightPane+  , runDefModes, runDefInventory+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Either+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Function+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Faction as Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.FactionKind as FK+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.PlaceKind as PK+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs++data ItemDialogState = ISuitable | IAll+  deriving (Show, Eq)++data ResultItemDialogMode =+    RStore CStore [ItemId]+  | ROwned ItemId+  | RLore SLore MenuSlot [(ItemId, ItemQuant)]+  | RSkills MenuSlot+  | RPlaces MenuSlot+  | RFactions MenuSlot+  | RModes MenuSlot+  deriving Show++accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag+accessModeBag leader s (MStore cstore) = let b = getActorBody leader s+                                         in getBodyStoreBag b cstore s+accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s+                                in combinedItems fid s+accessModeBag _ _ MSkills = EM.empty+accessModeBag leader s (MLore SBody) = let b = getActorBody leader s+                                       in getBodyStoreBag b COrgan s+accessModeBag _ s MLore{} = EM.map (const quantSingle) $ sitemD s+accessModeBag _ _ MPlaces = EM.empty+accessModeBag _ _ MFactions = EM.empty+accessModeBag _ _ MModes = EM.empty++-- | Let a human player choose any item from a given group.+-- Note that this does not guarantee the chosen item belongs to the group,+-- as the player can override the choice.+-- Used e.g., for applying and projecting.+getGroupItem :: MonadClientUI m+             => ActorId+             -> m Suitability+                          -- ^ which items to consider suitable+             -> Text      -- ^ specific prompt for only suitable items+             -> Text      -- ^ generic prompt+             -> Text      -- ^ the verb to use+             -> Text      -- ^ the generic verb to use+             -> [CStore]  -- ^ stores to cycle through+             -> m (Either Text (CStore, ItemId))+getGroupItem leader psuit prompt promptGeneric verb verbGeneric stores = do+  side <- getsClient sside+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! side+  let ppItemDialogBody v body actorSk cCur = case cCur of+        MStore CEqp | not $ calmEnough body actorSk ->+          "distractedly attempt to" <+> v <+> ppItemDialogModeIn cCur+        MStore CGround | mstash == Just (blid body, bpos body) ->+          "greedily attempt to" <+> v <+> ppItemDialogModeIn cCur+        _ -> v <+> ppItemDialogModeFrom cCur+  soc <- getFull leader psuit+                 (\body _ actorSk cCur _ ->+                    prompt <+> ppItemDialogBody verb body actorSk cCur)+                 (\body _ actorSk cCur _ ->+                    promptGeneric+                    <+> ppItemDialogBody verbGeneric body actorSk cCur)+                 stores True False+  case soc of+    Left err -> return $ Left err+    Right (rstore, [(iid, _)]) -> return $ Right (rstore, iid)+    Right _ -> error $ "" `showFailure` soc++-- | Display all items from a store and let the human player choose any+-- or switch to any other store.+-- Used, e.g., for viewing inventory and item descriptions.+getStoreItem :: MonadClientUI m+             => ActorId         -- ^ the pointman+             -> ItemDialogMode  -- ^ initial mode+             -> m (Either Text ResultItemDialogMode)+getStoreItem leader cInitial = do+  side <- getsClient sside+  let -- No @COrgan@, because triggerable organs are rare and,+      -- if really needed, accessible directly from the trigger menu.+      itemCs = map MStore [CStash, CEqp, CGround]+      -- This should match, including order, the items in standardKeysAndMouse+      -- marked with CmdDashboard up to @MSkills@.+      leaderCs = itemCs ++ [MOwned, MLore SBody, MSkills]+      -- No @SBody@, because repeated in other lores and included elsewhere.+      itemLoreCs = map MLore [minBound..SEmbed]+      -- This should match, including order, the items in standardKeysAndMouse+      -- marked with CmdDashboard past @MSkills@ and up to @MModes@.+      loreCs = itemLoreCs ++ [MPlaces, MFactions, MModes]+  let !_A1 = assert (null (leaderCs `intersect` loreCs)) ()+      !_A2 = assert (sort (leaderCs ++ loreCs ++ [MStore COrgan])+                     == map MStore [minBound..maxBound]+                        ++ [MOwned, MSkills]+                        ++ map MLore [minBound..maxBound]+                        ++ [MPlaces, MFactions, MModes]) ()+      allCs | cInitial `elem` leaderCs = leaderCs+            | cInitial `elem` loreCs = loreCs+            | otherwise = assert (cInitial == MStore COrgan) leaderCs+                            -- werrd content, but let it be+      (pre, rest) = break (== cInitial) allCs+      post = dropWhile (== cInitial) rest+      remCs = post ++ pre+      prompt = storeItemPrompt side+  getItem leader (return SuitsEverything) prompt prompt cInitial remCs+          True False++storeItemPrompt :: FactionId+                -> Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State+                -> Text+storeItemPrompt side body bodyUI actorCurAndMaxSk c2 s =+  let COps{coitem} = scops s+      fact = sfactionD s EM.! side+      (tIn, t) = ppItemDialogMode c2+      subject = partActor bodyUI+      f (k, _) acc = k + acc+      countItems store = EM.foldr' f 0 $ getBodyStoreBag body store s+  in case c2 of+    MStore CGround ->+      let n = countItems CGround+          nItems = MU.CarAWs n "item"+          verbGround = if gstash fact == Just (blid body, bpos body)+                       then "fondle greedily"+                       else "notice"+      in makePhrase+           [ MU.Capitalize $ MU.SubjectVerbSg subject verbGround+           , nItems, "at"+           , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text "feet" ]+    MStore CEqp ->+      let n = countItems CEqp+          (verbEqp, nItems) =+            if | n == 0 -> ("find nothing", "")+               | calmEnough body actorCurAndMaxSk ->+                   ("find", MU.CarAWs n "item")+               | otherwise -> ("paw distractedly at", MU.CarAWs n "item")+      in makePhrase+           [ MU.Capitalize $ MU.SubjectVerbSg subject verbEqp+           , nItems, MU.Text tIn+           , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+    MStore cstore ->+      let n = countItems cstore+          nItems = MU.CarAWs n "item"+          (verb, onLevel) = case cstore of+            COrgan -> ("feel", [])+            CStash ->+              ( "notice"+              , case gstash fact of+                  Just (lid, _) ->+                    map MU.Text ["on level", tshow $ abs $ fromEnum lid]+                  Nothing -> [] )+          ownObject = case cstore of+            CStash -> ["our", MU.Text t]+            _ -> [MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t]+      in makePhrase $+           [ MU.Capitalize $ MU.SubjectVerbSg subject verb+           , nItems, MU.Text tIn ] ++ ownObject ++ onLevel+    MOwned ->+      -- We assume "gold grain", not "grain" with label "of gold":+      let currencyName = IK.iname $ okind coitem+                         $ ouniqGroup coitem IK.S_CURRENCY+          dungeonTotal = sgold s+          (_, total) = calculateTotal side s+      in T.init $ spoilsBlurb currencyName total dungeonTotal+        -- no space for more, e.g., the pointman, but it can't be changed anyway+    MSkills ->+      makePhrase+        [ MU.Capitalize $ MU.SubjectVerbSg subject "estimate"+        , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+    MLore SBody ->+      makePhrase+        [ MU.Capitalize $ MU.SubjectVerbSg subject "feel"+        , MU.Text tIn+        , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ]+    MLore slore ->+      makePhrase+        [ MU.Capitalize $ MU.Text $+            if slore == SEmbed+            then "terrain (including crafting recipes)"+            else t ]+    MPlaces ->+      makePhrase+        [ MU.Capitalize $ MU.Text t ]+    MFactions ->+      makePhrase+        [ MU.Capitalize $ MU.Text t ]+    MModes ->+      makePhrase+        [ MU.Capitalize $ MU.Text t ]++-- | Let the human player choose a single, preferably suitable,+-- item from a list of items. Don't display stores empty for all actors.+-- Start with a non-empty store.+getFull :: MonadClientUI m+        => ActorId+        -> m Suitability    -- ^ which items to consider suitable+        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State+            -> Text)        -- ^ specific prompt for only suitable items+        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State+            -> Text)        -- ^ generic prompt+        -> [CStore]         -- ^ stores to cycle through+        -> Bool             -- ^ whether to ask, when the only item+                            --   in the starting mode is suitable+        -> Bool             -- ^ whether to permit multiple items as a result+        -> m (Either Text (CStore, [(ItemId, ItemQuant)]))+getFull leader psuit prompt promptGeneric stores askWhenLone permitMulitple = do+  mpsuit <- psuit+  let psuitFun = case mpsuit of+        SuitsEverything -> \_ _ _ -> True+        SuitsSomething f -> f+  -- Move the first store that is non-empty for suitable items for this actor+  -- to the front, if any.+  b <- getsState $ getActorBody leader+  getCStoreBag <- getsState $ \s cstore -> getBodyStoreBag b cstore s+  let hasThisActor = not . EM.null . getCStoreBag+  case filter hasThisActor stores of+    [] -> do+      let dialogModes = map MStore stores+          ts = map (MU.Text . ppItemDialogModeIn) dialogModes+      return $ Left $ "no items" <+> makePhrase [MU.WWxW "nor" ts]+    haveThis@(headThisActor : _) -> do+      itemToF <- getsState $ flip itemToFull+      let suitsThisActor store =+            let bag = getCStoreBag store+            in any (\(iid, kit) -> psuitFun (Just store) (itemToF iid) kit)+                   (EM.assocs bag)+          firstStore = fromMaybe headThisActor $ find suitsThisActor haveThis+          -- Don't display stores totally empty for all actors.+          breakStores cInit =+            let (pre, rest) = break (== cInit) stores+                post = dropWhile (== cInit) rest+            in (MStore cInit, map MStore $ post ++ pre)+          (modeFirst, modeRest) = breakStores firstStore+      res <- getItem leader psuit prompt promptGeneric modeFirst modeRest+                     askWhenLone permitMulitple+      case res of+        Left t -> return $ Left t+        Right (RStore fromCStore iids) -> do+          let bagAll = getCStoreBag fromCStore+              f iid = (iid, bagAll EM.! iid)+          return $ Right (fromCStore, map f iids)+        Right _ -> error $ "" `showFailure` res++-- | Let the human player choose a single, preferably suitable,+-- item from a list of items.+getItem :: MonadClientUI m+        => ActorId+        -> m Suitability    -- ^ which items to consider suitable+        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State+            -> Text)        -- ^ specific prompt for only suitable items+        -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State+            -> Text)        -- ^ generic prompt+        -> ItemDialogMode   -- ^ first mode to display+        -> [ItemDialogMode] -- ^ the (rest of) modes+        -> Bool             -- ^ whether to ask, when the only item+                            --   in the starting mode is suitable+        -> Bool             -- ^ whether to permit multiple items as a result+        -> m (Either Text ResultItemDialogMode)+getItem leader psuit prompt promptGeneric cCur cRest askWhenLone+        permitMulitple = do+  accessCBag <- getsState $ accessModeBag leader+  let storeAssocs = EM.assocs . accessCBag+      allAssocs = concatMap storeAssocs (cCur : cRest)+  case (allAssocs, cCur) of+    ([(iid, _)], MStore rstore) | null cRest && not askWhenLone ->+      return $ Right $ RStore rstore [iid]+    _ -> transition leader psuit prompt promptGeneric permitMulitple+                    cCur cRest ISuitable++data DefItemKey m = DefItemKey+  { defLabel  :: Either Text K.KM+  , defCond   :: Bool+  , defAction :: ~(m (Either Text ResultItemDialogMode))+      -- this field may be expensive or undefined when @defCond@ is false+  }++data Suitability =+    SuitsEverything+  | SuitsSomething (Maybe CStore -> ItemFull -> ItemQuant -> Bool)++transition :: forall m. MonadClientUI m+           => ActorId+           -> m Suitability+           -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State+               -> Text)+           -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State+               -> Text)+           -> Bool+           -> ItemDialogMode+           -> [ItemDialogMode]+           -> ItemDialogState+           -> m (Either Text ResultItemDialogMode)+transition leader psuit prompt promptGeneric permitMulitple+           cCur cRest itemDialogState = do+  let recCall cCur2 cRest2 itemDialogState2 = do+        -- Pointman could have been changed by keypresses near the end of+        -- the current recursive call, so refresh it for the next call.+        mleader <- getsClient sleader+        -- When run inside a test, without mleader, assume leader not changed.+        let leader2 = fromMaybe leader mleader+        transition leader2 psuit prompt promptGeneric permitMulitple+                   cCur2 cRest2 itemDialogState2+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  body <- getsState $ getActorBody leader+  bodyUI <- getsSession $ getActorUI leader+  fact <- getsState $ (EM.! bfid body) . sfactionD+  hs <- partyAfterLeader leader+  revCmd <- revCmdMap+  promptChosen <- getsState $ \s -> case itemDialogState of+    ISuitable -> prompt body bodyUI actorCurAndMaxSk cCur s <> ":"+    IAll -> promptGeneric body bodyUI actorCurAndMaxSk cCur s <> ":"+  let keyDefsCommon :: [(K.KM, DefItemKey m)]+      keyDefsCommon = filter (defCond . snd)+        [ let km = K.mkChar '<'+          in (km, changeContainerDef Backward $ Right km)+        , let km = K.mkChar '>'+          in (km, changeContainerDef Forward $ Right km)+        , cycleKeyDef Forward+        , cycleKeyDef Backward+        , cycleLevelKeyDef Forward+        , cycleLevelKeyDef Backward+        , (K.KM K.NoModifier K.LeftButtonRelease, DefItemKey+           { defLabel = Left ""+           , defCond = maySwitchLeader cCur && not (null hs)+           , defAction = do+               -- This is verbose even in aiming mode, displaying+               -- terrain description, but it's fine, mouse may do that.+               merror <- pickLeaderWithPointer leader+               case merror of+                 Nothing -> recCall cCur cRest itemDialogState+                 Just{} -> return $ Left "not a menu item nor teammate position"+                             -- don't inspect the error, it's expected+           })+        , (K.escKM, DefItemKey+           { defLabel = Right K.escKM+           , defCond = True+           , defAction = return $ Left "never mind"+           })+        ]+      cycleLevelKeyDef direction =+        let km = revCmd $ PointmanCycleLevel direction+        in (km, DefItemKey+                { defLabel = Left ""+                , defCond = maySwitchLeader cCur+                            && any (\(_, b, _) -> blid b == blid body) hs+                , defAction = do+                    err <- pointmanCycleLevel leader False direction+                    let !_A = assert (isNothing err `blame` err) ()+                    recCall cCur cRest itemDialogState+                })+      changeContainerDef direction defLabel =+        let (cCurAfterCalm, cRestAfterCalm) = nextContainers direction+        in DefItemKey+          { defLabel+          , defCond = cCurAfterCalm /= cCur+          , defAction = recCall cCurAfterCalm cRestAfterCalm itemDialogState+          }+      nextContainers direction = case direction of+        Forward -> case cRest ++ [cCur] of+          c1 : rest -> (c1, rest)+          [] -> error $ "" `showFailure` cRest+        Backward -> case reverse $ cCur : cRest of+          c1 : rest -> (c1, reverse rest)+          [] -> error $ "" `showFailure` cRest+      banned = bannedPointmanSwitchBetweenLevels fact+      maySwitchLeader MStore{} = True+      maySwitchLeader MOwned = False+      maySwitchLeader MSkills = True+      maySwitchLeader (MLore SBody) = True+      maySwitchLeader MLore{} = False+      maySwitchLeader MPlaces = False+      maySwitchLeader MFactions = False+      maySwitchLeader MModes = False+      cycleKeyDef direction =+        let km = revCmd $ PointmanCycle direction+        in (km, DefItemKey+               { defLabel = if direction == Forward then Right km else Left ""+               , defCond = maySwitchLeader cCur && not (banned || null hs)+               , defAction = do+                   err <- pointmanCycle leader False direction+                   let !_A = assert (isNothing err `blame` err) ()+                   recCall cCur cRest itemDialogState+               })+  case cCur of+    MSkills -> runDefSkills keyDefsCommon promptChosen leader+    MPlaces -> runDefPlaces keyDefsCommon promptChosen+    MFactions -> runDefFactions keyDefsCommon promptChosen+    MModes -> runDefModes keyDefsCommon promptChosen+    _ -> do+      bagHuge <- getsState $ \s -> accessModeBag leader s cCur+      itemToF <- getsState $ flip itemToFull+      mpsuit <- psuit  -- when throwing, this sets eps and checks xhair validity+      psuitFun <- case mpsuit of+        SuitsEverything -> return $ \_ _ _ -> True+        SuitsSomething f -> return f  -- When throwing, this function takes+                                      -- missile range into accout.+      ItemRoles itemRoles <- getsSession sroles+      let slore = loreFromMode cCur+          itemRole = itemRoles EM.! slore+          bagAll = EM.filterWithKey (\iid _ -> iid `ES.member` itemRole) bagHuge+          mstore = case cCur of+            MStore store -> Just store+            _ -> Nothing+          filterP = psuitFun mstore . itemToF+          bagSuit = EM.filterWithKey filterP bagAll+          bagFiltered = case itemDialogState of+            ISuitable -> bagSuit+            IAll -> bagAll+          iids = sortIids itemToF $ EM.assocs bagFiltered+          keyDefsExtra =+            [ let km = K.mkChar '+'+              in (km, DefItemKey+               { defLabel = Right km+               , defCond = bagAll /= bagSuit+               , defAction = recCall cCur cRest $ case itemDialogState of+                                                    ISuitable -> IAll+                                                    IAll -> ISuitable+               })+            , let km = K.mkChar '*'+              in (km, useMultipleDef $ Right km)+            , let km = K.mkChar '!'+              in (km, useMultipleDef $ Left "")  -- alias close to 'g'+            ]+          useMultipleDef defLabel = DefItemKey+            { defLabel+            , defCond = permitMulitple && not (null iids)+            , defAction = case cCur of+                MStore rstore -> return $! Right $ RStore rstore $ map fst iids+                _ -> error "transition: multiple items not for MStore"+            }+          keyDefs = keyDefsCommon ++ filter (defCond . snd) keyDefsExtra+      runDefInventory keyDefs promptChosen leader cCur iids++runDefMessage :: MonadClientUI m+              => [(K.KM, DefItemKey m)]+              -> Text+              -> m ()+runDefMessage keyDefs prompt = do+  let wrapB s = "[" <> s <> "]"+      keyLabelsRaw = lefts $ map (defLabel . snd) keyDefs+      keyLabels = filter (not . T.null) keyLabelsRaw+      choice = T.intercalate " " $ map wrapB $ nub keyLabels+        -- switch to Data.Containers.ListUtils.nubOrd when we drop GHC 8.4.4+  msgAdd MsgPromptGeneric $ prompt <+> choice++runDefAction :: MonadClientUI m+             => [(K.KM, DefItemKey m)]+             -> (MenuSlot -> Either Text ResultItemDialogMode)+             -> KeyOrSlot+             -> m (Either Text ResultItemDialogMode)+runDefAction keyDefs slotDef ekm = case ekm of+  Left km -> case km `lookup` keyDefs of+    Just keyDef -> defAction keyDef+    Nothing -> error $ "unexpected key:" `showFailure` K.showKM km+  Right slot -> return $! slotDef slot++runDefSkills :: MonadClientUI m+             => [(K.KM, DefItemKey m)] -> Text -> ActorId+             -> m (Either Text ResultItemDialogMode)+runDefSkills keyDefsCommon promptChosen leader = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  runDefMessage keyDefsCommon promptChosen+  let itemKeys = map fst keyDefsCommon+      keys = rights $ map (defLabel . snd) keyDefsCommon+  okx <- skillsOverlay leader+  sli <- overlayToSlideshow (rheight - 2) keys okx+  ekm <- displayChoiceScreenWithDefItemKey+           (skillsInRightPane leader) sli itemKeys (show MSkills)+  runDefAction keyDefsCommon (Right . RSkills) ekm++skillsInRightPane :: MonadClientUI m => ActorId -> Int -> MenuSlot -> m OKX+skillsInRightPane leader width slot = do+  FontSetup{propFont} <- getFontSetup+  (prompt, attrString) <- skillCloseUp leader slot+  let promptAS | T.null prompt = []+               | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n"+      ov = EM.singleton propFont $ offsetOverlay+                                 $ splitAttrString width width+                                 $ promptAS ++ attrString+  return (ov, [])++runDefPlaces :: MonadClientUI m+             => [(K.KM, DefItemKey m)] -> Text+             -> m (Either Text ResultItemDialogMode)+runDefPlaces keyDefsCommon promptChosen = do+  COps{coplace} <- getsState scops+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  soptions <- getsClient soptions+  places <- getsState $ EM.assocs+                      . placesFromState coplace (sexposePlaces soptions)+  runDefMessage keyDefsCommon promptChosen+  let itemKeys = map fst keyDefsCommon+      keys = rights $ map (defLabel . snd) keyDefsCommon+  okx <- placesOverlay+  sli <- overlayToSlideshow (rheight - 2) keys okx+  ekm <- displayChoiceScreenWithDefItemKey+           (placesInRightPane places) sli itemKeys (show MPlaces)+  runDefAction keyDefsCommon (Right . RPlaces) ekm++placesInRightPane :: MonadClientUI m+                  => [( ContentId PK.PlaceKind+                      , (ES.EnumSet LevelId, Int, Int, Int) )]+                  -> Int -> MenuSlot+                  -> m OKX+placesInRightPane places width slot = do+  FontSetup{propFont} <- getFontSetup+  soptions <- getsClient soptions+  (prompt, blurbs) <- placeCloseUp places (sexposePlaces soptions) slot+  let promptAS | T.null prompt = []+               | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n"+      splitText = splitAttrString width width+      ov = attrLinesToFontMap+           $ map (second $ concatMap splitText)+           $ (propFont, [promptAS]) : blurbs+  return (ov, [])++runDefFactions :: MonadClientUI m+               => [(K.KM, DefItemKey m)] -> Text+               -> m (Either Text ResultItemDialogMode)+runDefFactions keyDefsCommon promptChosen = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  sroles <- getsSession sroles+  factions <- getsState $ factionsFromState sroles+  runDefMessage keyDefsCommon promptChosen+  let itemKeys = map fst keyDefsCommon+      keys = rights $ map (defLabel . snd) keyDefsCommon+  okx <- factionsOverlay+  sli <- overlayToSlideshow (rheight - 2) keys okx+  ekm <- displayChoiceScreenWithDefItemKey+           (factionsInRightPane factions)+           sli itemKeys (show MFactions)+  runDefAction keyDefsCommon (Right . RFactions) ekm++factionsInRightPane :: MonadClientUI m+                    => [(FactionId, Faction)]+                    -> Int -> MenuSlot+                    -> m OKX+factionsInRightPane factions width slot = do+  FontSetup{propFont} <- getFontSetup+  (prompt, blurbs) <- factionCloseUp factions slot+  let promptAS | T.null prompt = []+               | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n"+      splitText = splitAttrString width width+      ov = attrLinesToFontMap+           $ map (second $ concatMap splitText)+           $ (propFont, [promptAS]) : blurbs+  return (ov, [])++runDefModes :: MonadClientUI m+            => [(K.KM, DefItemKey m)] -> Text+            -> m (Either Text ResultItemDialogMode)+runDefModes keyDefsCommon promptChosen = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  runDefMessage keyDefsCommon promptChosen+  let itemKeys = map fst keyDefsCommon+      keys = rights $ map (defLabel . snd) keyDefsCommon+  okx <- modesOverlay+  sli <- overlayToSlideshow (rheight - 2) keys okx+  -- Modes would cover the whole screen, so we don't display in right pane.+  -- But we display and highlight menu bullets.+  ekm <- displayChoiceScreenWithDefItemKey+           (\_ _ -> return emptyOKX) sli itemKeys (show MModes)+  runDefAction keyDefsCommon (Right . RModes) ekm++runDefInventory :: MonadClientUI m+                => [(K.KM, DefItemKey m)]+                -> Text+                -> ActorId+                -> ItemDialogMode+                -> [(ItemId, ItemQuant)]+                -> m (Either Text ResultItemDialogMode)+runDefInventory keyDefs promptChosen leader dmode iids = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  let meleeSkill = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk+      slotDef :: MenuSlot -> Either Text ResultItemDialogMode+      slotDef slot =+        let iid = fst $ iids !! fromEnum slot+        in Right $ case dmode of+          MStore rstore -> RStore rstore [iid]+          MOwned -> ROwned iid+          MLore rlore -> RLore rlore slot iids+          _ -> error $ "" `showFailure` dmode+      promptFun _iid _itemFull _k = ""+        -- TODO, e.g., if the party still owns any copies, if the actor+        -- was ever killed by us or killed ours, etc.+        -- This can be the same prompt or longer than what entering+        -- the item screen shows.+  runDefMessage keyDefs promptChosen+  let itemKeys = map fst keyDefs+      keys = rights $ map (defLabel . snd) keyDefs+  okx <- itemOverlay iids dmode+  sli <- overlayToSlideshow (rheight - 2) keys okx+  ekm <- displayChoiceScreenWithDefItemKey+           (okxItemLoreInline promptFun meleeSkill dmode iids)+           sli itemKeys (show dmode)+  runDefAction keyDefs slotDef ekm++skillCloseUp :: MonadClientUI m => ActorId -> MenuSlot -> m (Text, AttrString)+skillCloseUp leader slot = do+  b <- getsState $ getActorBody leader+  bUI <- getsSession $ getActorUI leader+  actorCurAndMaxSk <- getsState $ getActorMaxSkills leader+  let skill = skillsInDisplayOrder !! fromEnum slot+      valueText = skillToDecorator skill b+                  $ Ability.getSk skill actorCurAndMaxSk+      prompt = makeSentence+        [ MU.WownW (partActor bUI) (MU.Text $ skillName skill)+        , "is", MU.Text valueText ]+      attrString = textToAS $ skillDesc skill+  return (prompt, attrString)++placeCloseUp :: MonadClientUI m+             => [(ContentId PK.PlaceKind, (ES.EnumSet LevelId, Int, Int, Int))]+             -> Bool+             -> MenuSlot+             -> m (Text, [(DisplayFont, [AttrString])])+placeCloseUp places sexposePlaces slot = do+  COps{coplace} <- getsState scops+  FontSetup{..} <- getFontSetup+  let (pk, (es, ne, na, _)) = places !! fromEnum slot+      pkind = okind coplace pk+      prompt = makeSentence ["you remember", MU.Text $ PK.pname pkind]+      freqsText = "Frequencies:" <+> T.intercalate " "+        (map (\(grp, n) -> "(" <> displayGroupName grp+                           <> ", " <> tshow n <> ")")+         $ PK.pfreq pkind)+      onLevels | ES.null es = []+               | otherwise = [makeSentence+                               [ "Appears on"+                               , MU.CarWs (ES.size es) "level" <> ":"+                               , MU.WWandW $ map MU.Car $ sort+                                 $ map (abs . fromEnum) $ ES.elems es ]]+      placeParts = ["it has" | ne > 0 || na > 0]+                   ++ [MU.CarWs ne "entrance" | ne > 0]+                   ++ ["and" | ne > 0 && na > 0]+                   ++ [MU.CarWs na "surrounding" | na > 0]+      partsSentence | null placeParts = []+                    | otherwise = [makeSentence placeParts, "\n"]+      blurbs = [(propFont, partsSentence)]+               ++ [(monoFont, [freqsText, "\n"]) | sexposePlaces]+               ++ [(squareFont, PK.ptopLeft pkind ++ ["\n"]) | sexposePlaces]+               ++ [(propFont, onLevels)]+  return (prompt, map (second $ map textToAS) blurbs)++factionCloseUp :: MonadClientUI m+               => [(FactionId, Faction)]+               -> MenuSlot+               -> m (Text, [(DisplayFont, [AttrString])])+factionCloseUp factions slot = do+  side <- getsClient sside+  FontSetup{propFont} <- getFontSetup+  factionD <- getsState sfactionD+  let (fid, fact@Faction{gkind=FK.FactionKind{..}, ..}) =+        factions !! fromEnum slot+      (name, person) = if fhasGender  -- but we ignore "Controlled", etc.+                       then (makePhrase [MU.Ws $ MU.Text fname], MU.PlEtc)+                       else (fname, MU.Sg3rd)+      (youThey, prompt) =+        if fid == side+        then ("You", makeSentence  ["you are the", MU.Text name])+        else ("They", makeSentence ["you are wary of the", MU.Text name])+               -- wary even if the faction is allied+      ts1 =+        -- Display only the main groups, not to spam.+        case map fst $ filter ((>= 100) . snd) fgroups of+          [] -> []  -- only initial actors in the faction?+          [fgroup] ->+            [makeSentence [ "the faction consists of"+                          , MU.Ws $ MU.Text $ displayGroupName fgroup ]]+          grps -> [makeSentence+                    [ "the faction attracts members such as:"+                    ,  MU.WWandW $ map (MU.Text . displayGroupName) grps ]]+        ++ [if fskillsOther == Ability.zeroSkills  -- simplified+            then youThey <+> "don't care about each other and crowd and stampede all at once, sometimes brutally colliding by accident."+            else youThey <+> "pay attention to each other and take care to move one at a time."]+        ++ [ if fcanEscape+             then "The faction is able to take part in races to an area exit."+             else "The faction doesn't escape areas of conflict and attempts to block exits instead."]+        ++ [ "When all members are incapacitated, the faction dissolves."+           | fneverEmpty ]+        ++ [if fhasGender+            then "Its members are known to have sexual dimorphism and use gender pronouns."+            else "Its members seem to prefer naked ground for sleeping."]+        ++ [ "Its ranks swell with time."+           | fspawnsFast ]+        ++ [ "The faction is able to maintain activity on a level on its own, with a pointman coordinating each tactical maneuver."+           | fhasPointman ]+      -- Changes to all of these have visibility @PosAll@, so the player+      -- knows them fully, except for @gvictims@, which is coupled to tracking+      -- other factions' actors and so only incremented when we've seen+      -- their actor killed (mostly likely killed by us).+      ts2 =  -- reporting regardless of whether any of the factions are dead+        let renderDiplGroup [] = error "renderDiplGroup: null"+            renderDiplGroup ((fid2, diplomacy) : rest) = MU.Phrase+              [ MU.Text $ tshowDiplomacy diplomacy+              , "with"+              , MU.WWandW $ map renderFact2 $ fid2 : map fst rest ]+            renderFact2 fid2 = MU.Text $ Faction.gname (factionD EM.! fid2)+            valid (fid2, diplomacy) = isJust (lookup fid2 factions)+                                      && diplomacy /= Unknown+            knownAssocsGroups = groupBy ((==) `on` snd) $ sortOn snd+                                $ filter valid $ EM.assocs gdipl+        in [ makeSentence [ MU.SubjectVerb person MU.Yes (MU.Text name) "be"+                          , MU.WWandW $ map renderDiplGroup knownAssocsGroups ]+           | not (null knownAssocsGroups) ]+      ts3 =+        case gquit of+          Just Status{..} | not $ isHorrorFact fact ->+            ["The faction has already" <+> FK.nameOutcomePast stOutcome+             <+> "around level" <+> tshow (abs stDepth) <> "."]+          _ -> []+        ++ let nkilled = sum $ EM.elems gvictims+               personKilled = if nkilled == 1 then MU.Sg3rd else MU.PlEtc+           in [ makeSentence $+                  [ "so far," | isNothing gquit ]+                  ++ [ "at least"+                     , MU.CardinalWs nkilled "member"+                     , MU.SubjectVerb personKilled+                                      MU.Yes+                                      "of this faction"+                                      "have been incapacitated" ]+              | nkilled > 0 ]+        ++ let adjective = if isNothing gquit then "current" else "last"+               verb = if isNothing gquit then "is" else "was"+           in ["Its" <+> adjective <+> "doctrine" <+> verb+               <+> "'" <> Ability.nameDoctrine gdoctrine+               <> "' (" <> Ability.describeDoctrine gdoctrine <> ")."]+      -- Description of the score polynomial would go into a separate section,+      -- but it's hard to make it sound non-technical enough.+      blurbs = intersperse ["\n"] $ filter (not . null) [ts1, ts2, ts3]+  return (prompt, map (\t -> (propFont, map textToAS t)) blurbs)
+ engine-src/Game/LambdaHack/Client/UI/ItemDescription.hs view
@@ -0,0 +1,542 @@+-- | Descriptions of items.+module Game.LambdaHack.Client.UI.ItemDescription+  ( partItem, partItemShort, partItemShortest, partItemHigh+  , partItemWsDetail, partItemWs, partItemWsShortest, partItemWsShort+  , partItemWsLong, partItemWsRanged+  , partItemShortAW, partItemMediumAW, partItemShortWownW+  , viewItem, viewItemBenefitColored, itemDesc+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , partItemN, textAllPowers+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Char (isAlpha, isAlphaNum)+import qualified Data.EnumMap.Strict as EM+import           Data.Int (Int64)+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.Flavour++partItemN :: Int -> FactionId -> FactionDict -> Bool -> DetailLevel -> Int+          -> Time -> ItemFull -> ItemQuant+          -> (MU.Part, MU.Part)+partItemN width side factionD ranged detailLevel maxWordsToShow localTime+          itemFull kit =+  let (_, r2, r3) =+        partItemN3 width side factionD ranged detailLevel maxWordsToShow+                   localTime itemFull kit+  in (r2, r3)++-- | The part of speech describing the item parameterized by the number+-- of effects/aspects to show.+partItemN3 :: Int -> FactionId -> FactionDict -> Bool -> DetailLevel -> Int+           -> Time -> ItemFull -> ItemQuant+           -> ([Text], MU.Part, MU.Part)+partItemN3 width side factionD ranged detailLevel maxWordsToShow localTime+           itemFull@ItemFull{itemBase, itemKind, itemSuspect}+           (itemK, itemTimers) =+  let flav = flavourToName $ jflavour itemBase+      arItem = aspectRecordFull itemFull+      timeout = IA.aTimeout arItem+      temporary = IA.checkFlag Ability.Fragile arItem+                  && IA.checkFlag Ability.Periodic arItem+      ncha = ncharges localTime (itemK, itemTimers)+      charges | temporary = case itemTimers of+                  [] -> if itemK == ncha+                        then ""+                        else error $ "partItemN3: charges with null timer"+                                     `showFailure`+                                     (side, itemFull, itemK, itemTimers)+                  t : _ -> if itemK == ncha+                           then "(ready to expire)"+                           else let total = deltaOfItemTimer localTime t+                                in "for" <+> timeDeltaInSecondsText total+              | itemK == ncha = ""+              | itemK == 1 && ncha == 0 = "(charging)"+              | ncha == 0 = "(all charging)"+              | otherwise = "(" <> tshow (itemK - ncha) <+> "charging)"+      skipRecharging = detailLevel <= DetailLow && ncha == 0+      (orTs, powerTs, rangedDamage) =+        textAllPowers width detailLevel skipRecharging itemFull+      lsource = case jfid itemBase of+        Just fid | IK.iname itemKind == "impressed" ->+          ["by" <+> if fid == side+                    then "us"+                    else gname (factionD EM.! fid)]+        _ -> []+      powerTsBeginsWithAlphaOrNum = case map T.unpack powerTs of+        (c : _) : _ -> isAlpha c || isAlphaNum c+        _ -> False+      -- Ranged damage displayed even if lack of space, to prevent confusion+      -- and ... when only ranged damage is missing from the description.+      displayPowers = maxWordsToShow > 1+                      || powerTsBeginsWithAlphaOrNum && length powerTs == 1+      ts = lsource+           ++ (if displayPowers+               then take maxWordsToShow powerTs+               else [])+           ++ ["(...)" | displayPowers && length powerTs > maxWordsToShow]+           ++ (if displayPowers && ranged then rangedDamage else [])+           ++ [charges | maxWordsToShow > 1]+      name | temporary =+             let adj = if timeout == 0 then "temporarily" else "impermanent"+             in adj <+> IK.iname itemKind+           | itemSuspect = flav <+> IK.iname itemKind+           | otherwise = IK.iname itemKind+  in (orTs, MU.Text name, if displayPowers+                          then MU.Phrase $ map MU.Text ts+                          else MU.Text $ IA.aELabel arItem)++-- TODO: simplify the code a lot+textAllPowers :: Int -> DetailLevel -> Bool -> ItemFull+              -> ([Text], [Text], [Text])+textAllPowers width detailLevel skipRecharging+              itemFull@ItemFull{itemKind, itemDisco} =+  let arItem = aspectRecordFull itemFull+      -- To handle both the cases of item identified and not, we represent+      -- aspects as a list with dice, not a record of integers as in @arItem@.+      -- If item fully known, the dice will be trivial and will display+      -- the same as integers would, so nothing is lost.+      -- If item not known fully and timeouts or any crucial flags+      -- are under @Odds@, they are ignored, so they should be avoided+      -- under @Odds@ in not fully-identified items.+      aspectsFull = case itemDisco of+        ItemDiscoMean IA.KindMean{..} | kmConst ->+          IA.aspectRecordToList kmMean  -- exact and collated+        ItemDiscoMean{} -> IK.iaspects itemKind+          -- doesn't completely lose the @Odds@ case, so better than+          -- the above, even if does not collate multiple skill bonuses+        ItemDiscoFull iAspect -> IA.aspectRecordToList iAspect+      mtimeout = find IK.timeoutAspect aspectsFull+      elab = IA.aELabel arItem+      periodic = IA.checkFlag Ability.Periodic arItem+      hurtMeleeAspect :: IK.Aspect -> Bool+      hurtMeleeAspect (IK.AddSkill Ability.SkHurtMelee _) = True+      hurtMeleeAspect _ = False+      active = IA.goesIntoEqp arItem+      splitA :: DetailLevel -> [IK.Aspect] -> ([Text], [Text])+      splitA detLev aspects =+        let ppA = kindAspectToSuffix+            ppE = effectToSuffix detLev+            reduce_a = maybe "?" tshow . Dice.reduceDice+            restEs | detLev >= DetailMedium+                     || not (IA.checkFlag Ability.MinorEffects arItem) =+                     IK.ieffects itemKind+                   | otherwise = []+            (smashEffs, noSmashEffs) = partition IK.onSmashEffect restEs+            unSmash (IK.OnSmash eff) = eff+            unSmash eff = eff+            onSmashTs = T.intercalate " " $ filter (not . T.null)+                        $ map (ppE . unSmash) smashEffs+            unCombine (IK.OnCombine eff) = eff+            unCombine eff = eff+            (combineEffsRaw, noSmashCombineEffsRaw) =+              partition IK.onCombineEffect noSmashEffs+            onCombineRawTs = T.intercalate " " $ filter (not . T.null)+                             $ map (ppE . unCombine) combineEffsRaw+            onCombineRawTsTooLarge =+              detailLevel >= DetailHigh && T.length onCombineRawTs > 120+            (combineEffs, noSmashCombineEffs) =+              if onCombineRawTsTooLarge+              then (combineEffsRaw, noSmashCombineEffsRaw)+              else ([], noSmashEffs)+            unOr (IK.OrEffect eff1 eff2) = unOr eff1 ++ unOr eff2+            unOr eff = [eff]+            ppAnd (IK.AndEffect (IK.ConsumeItems tools raw) eff) =+              let (tcraft, traw, ttools) = describeCrafting tools raw eff+              in if T.length tcraft + T.length traw + T.length ttools+                    <= width - 4+                 then tcraft <+> traw <+> ttools+                 else tcraft <> "\n---" <+> traw <> "\n---" <+> ttools+            ppAnd eff = ppE eff+            ppOr eff = "*" <+> T.intercalate "\n* "+                               (nub $ filter (not . T.null)+                                    $ map ppAnd $ unOr eff)+            onCombineTs =+              filter (not . T.null) $ map (ppOr . unCombine) combineEffs+            rechargingTs = T.intercalate " "+                           $ [damageText | IK.idamage itemKind /= 0]+                             ++ filter (not . T.null)+                                       (map ppE noSmashCombineEffs)+            fragile = IA.checkFlag Ability.Fragile arItem+            periodicText =+              if periodic && not skipRecharging && not (T.null rechargingTs)+              then case (mtimeout, fragile) of+                     (Nothing, True) ->+                       "(each turn until gone:" <+> rechargingTs <> ")"+                     (Nothing, False) ->+                       "(each turn:" <+> rechargingTs <> ")"+                         -- timeout 0, so it just fires each turn and it's not+                         -- fragile, so a copy is not destroyed each turn+                     (Just (IK.Timeout t), True) ->+                       "(every" <+> reduce_a t <+> "until gone:"+                       <+> rechargingTs <> ")"+                     (Just (IK.Timeout t), False) ->+                       "(every" <+> reduce_a t <> ":" <+> rechargingTs <> ")"+                     _ -> error $ "" `showFailure` mtimeout+              else ""+            ppERestEs = if periodic+                        then [periodicText]+                        else map ppE noSmashCombineEffs+            aes = if active+                  then map ppA aspects ++ ppERestEs+                  else ppERestEs ++ map ppA aspects+            onSmash = if T.null onSmashTs then ""+                      else "(on smash:" <+> onSmashTs <> ")"+            onCombine = if null combineEffs && not (T.null onCombineRawTs)+                        then "(on combine:" <+> onCombineRawTs <> ")"+                        else ""+            -- Either exact value or dice of @SkHurtMelee@ needed,+            -- never the average, so @arItem@ not consulted directly.+            -- If item not known fully and @SkHurtMelee@ under @Odds@,+            -- it's ignored.+            damageText = case find hurtMeleeAspect aspects of+              Just (IK.AddSkill Ability.SkHurtMelee hurtMelee) ->+                (if IK.idamage itemKind == 0+                 then "0d0"+                 else tshow (IK.idamage itemKind))+                <> affixDice hurtMelee <> "%"+              _ -> if IK.idamage itemKind == 0+                   then ""+                   else tshow (IK.idamage itemKind)+            timeoutText = case mtimeout of+              Nothing -> ""+              Just (IK.Timeout t) -> "(cooldown" <+> reduce_a t <> ")"+                                       -- timeout is called "cooldown" in UI+              _ -> error $ "" `showFailure` mtimeout+       in ( onCombineTs+          , [damageText]+            ++ [timeoutText | detLev > DetailLow && not periodic]+            ++ aes+            ++ if detLev >= DetailHigh+               then [onCombine, onSmash]+               else [onCombineRawTs] )+      hurtMult = armorHurtCalculation True (IA.aSkills arItem)+                                           Ability.zeroSkills+      dmg = Dice.meanDice $ IK.idamage itemKind+      rawDeltaHP = ceiling $ intToDouble hurtMult * xD dmg / 100+      IK.ThrowMod{IK.throwVelocity} = IA.aToThrow arItem+      speed = speedFromWeight (IK.iweight itemKind) throwVelocity+      pdeltaHP = modifyDamageBySpeed rawDeltaHP speed+      rangedDamageDesc = [ "{avg" <+> show64With2 pdeltaHP <+> "ranged}"+                         | pdeltaHP > 0 ]+        -- Note that avg melee damage would be too complex to display here,+        -- because in case of @MOwned@ the owner is different than leader,+        -- so the value would be different than when viewing the item.+      splitTry ass =+        let splits = map (`splitA` ass) [minBound..maxBound]+            splitsToTry = drop (fromEnum detailLevel) splits+            splitsValid | T.null elab = filter (/= ([], [])) splitsToTry+                        | otherwise = splitsToTry+        in case splitsValid of+          (onCombineTsSplit, tsSplit) : _ -> (onCombineTsSplit, tsSplit)+          [] -> ([], [])+      (onCombineTsAss, aspectDescs) =+        let aMain IK.AddSkill{} = True+            aMain _ = False+            (aspectsMain, aspectsAux) = partition aMain aspectsFull+            (onCombineTsSplit, tsSplit) = splitTry aspectsMain+        in ( onCombineTsSplit+           , filter (/= "")+             $ elab+               : tsSplit+               ++ if detailLevel >= DetailHigh+                  then map kindAspectToSuffix aspectsAux+                  else [] )+  in (onCombineTsAss, aspectDescs, rangedDamageDesc)++-- | The part of speech describing the item.+partItem :: Int -> FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant+         -> (MU.Part, MU.Part)+partItem width side factionD =+  partItemN width side factionD False DetailLow 4++partItemShort :: Int -> FactionId -> FactionDict -> Time -> ItemFull+              -> ItemQuant+              -> (MU.Part, MU.Part)+partItemShort width side factionD =+  partItemN width side factionD False DetailLow 4++partItemShortest :: Int -> FactionId -> FactionDict -> Time -> ItemFull+                 -> ItemQuant+                 -> (MU.Part, MU.Part)+partItemShortest width side factionD =+  partItemN width side factionD False DetailLow 1++partItemHigh :: Int -> FactionId -> FactionDict -> Time -> ItemFull -> ItemQuant+             -> ([Text], MU.Part, MU.Part)+partItemHigh width side factionD =+  partItemN3 width side factionD False DetailHigh 100++-- The @count@ can be different than @itemK@ in @ItemFull@, e.g., when picking+-- a subset of items to drop.+partItemWsRanged :: Int -> FactionId -> FactionDict -> Bool -> DetailLevel+                 -> Int -> Int -> Time -> ItemFull -> ItemQuant+                 -> MU.Part+partItemWsRanged width side factionD ranged detail+                 maxWordsToShow count localTime itemFull kit =+  let (name, powers) = partItemN width side factionD ranged detail+                                 maxWordsToShow localTime itemFull kit+      arItem = aspectRecordFull itemFull+      periodic = IA.checkFlag Ability.Periodic arItem+      condition = IA.checkFlag Ability.Condition arItem+      maxCount = Dice.supDice $ IK.icount $ itemKind itemFull+  in if | condition && count == 1 -> MU.Phrase [name, powers]+        | condition && not periodic && maxCount > 1 ->+            let percent = 100 * count `divUp` maxCount+                amount = tshow count <> "-strong"+                         <+> "(" <> tshow percent <> "%)"+            in MU.Phrase [MU.Text amount, name, powers]+        | condition ->+            MU.Phrase [MU.Text $ tshow count <> "-fold", name, powers]+        | IA.checkFlag Ability.Unique arItem -> case count of+            0 -> MU.Phrase ["none of", name, powers]+            1 -> MU.Phrase [name, powers]+            _ -> MU.Phrase [MU.Car count, "of", MU.Ws name, powers]+        | otherwise -> MU.Phrase [MU.CarAWs count name, powers]++partItemWsDetail :: DetailLevel+                 -> Int -> FactionId -> FactionDict -> Int -> Time -> ItemFull+                 -> ItemQuant+                 -> MU.Part+partItemWsDetail DetailLow = partItemWsShortest+partItemWsDetail DetailMedium = partItemWs+partItemWsDetail DetailHigh = partItemWsLong+partItemWsDetail DetailAll = partItemWsLong++partItemWs :: Int -> FactionId -> FactionDict -> Int -> Time -> ItemFull+           -> ItemQuant+           -> MU.Part+partItemWs width side factionD =+  partItemWsRanged width side factionD False DetailLow 4++partItemWsShortest :: Int -> FactionId -> FactionDict -> Int -> Time -> ItemFull+                   -> ItemQuant+                   -> MU.Part+partItemWsShortest width side factionD =+  partItemWsRanged width side factionD False DetailLow 1++partItemWsShort :: Int -> FactionId -> FactionDict -> Int -> Time -> ItemFull+                -> ItemQuant+                -> MU.Part+partItemWsShort width side factionD =+  partItemWsRanged width side factionD False DetailLow 4++partItemWsLong :: Int -> FactionId -> FactionDict -> Int -> Time -> ItemFull+               -> ItemQuant+               -> MU.Part+partItemWsLong width side factionD =+  partItemWsRanged width side factionD False DetailMedium 100++partItemShortAW :: Int -> FactionId -> FactionDict -> Time -> ItemFull+                -> ItemQuant+                -> MU.Part+partItemShortAW width side factionD localTime itemFull kit =+  let (name, _) = partItemShort width side factionD localTime itemFull kit+      arItem = aspectRecordFull itemFull+  in if IA.checkFlag Ability.Unique arItem then name else MU.AW name++partItemMediumAW :: Int -> FactionId -> FactionDict -> Time -> ItemFull+                 -> ItemQuant+                 -> MU.Part+partItemMediumAW width side factionD localTime itemFull kit =+  let (name, powers) =+        partItemN width side factionD False DetailLow 100 localTime+                  itemFull kit+      arItem = aspectRecordFull itemFull+      phrase = MU.Phrase [name, powers]+  in if IA.checkFlag Ability.Unique arItem then phrase else MU.AW phrase++partItemShortWownW :: Int -> FactionId -> FactionDict -> MU.Part -> Time+                   -> ItemFull -> ItemQuant+                   -> MU.Part+partItemShortWownW width side factionD partA localTime itemFull kit =+  let (name, _) = partItemShort width side factionD localTime itemFull kit+  in MU.WownW partA name++viewItem :: ItemFull -> Color.AttrCharW32+{-# INLINE viewItem #-}+viewItem itemFull =+  Color.attrChar2ToW32 (flavourToColor $ jflavour $ itemBase itemFull)+                       (displayContentSymbol $ IK.isymbol $ itemKind itemFull)++viewItemBenefitColored :: DiscoveryBenefit -> ItemId -> ItemFull+                       -> Color.AttrCharW32+viewItemBenefitColored discoBenefit iid itemFull =+  -- The map @discoBenefit@ is normally used by AI to tell it in what role+  -- an item can be employed. In particular, ` benInEqp` says if an item+  -- buffs stats enough (and nerfs not too much) to be worth equipping.+  -- Here it's (ab)used to tell if an item (only a status effect item+  -- in this case, marked with `Ability.Condition`) is beneficial or not+  -- and to signal that in the organs UI menu.+  let color = if benInEqp (discoBenefit EM.! iid)+                  then Color.BrGreen+                  else Color.BrRed+  in Color.attrChar2ToW32+       color (displayContentSymbol $ IK.isymbol $ itemKind itemFull)++itemDesc :: Int -> Bool -> FactionId -> FactionDict -> Int -> ItemDialogMode+         -> Time -> LevelId -> ItemFull -> ItemQuant+         -> AttrString+itemDesc width markParagraphs side factionD aHurtMeleeOfOwner dmode localTime+         jlid itemFull@ItemFull{itemBase, itemKind, itemDisco, itemSuspect}+         kit =+  let (orTs, name, powers) =+        partItemHigh width side factionD localTime itemFull kit+      arItem = aspectRecordFull itemFull+      npowers = makePhrase [name, powers]+      IK.ThrowMod{IK.throwVelocity, IK.throwLinger} = IA.aToThrow arItem+      speed = speedFromWeight (IK.iweight itemKind) throwVelocity+      range = rangeFromSpeedAndLinger speed throwLinger+      plausiblyThrown =+        dmode `elem` [ MStore CGround, MStore CEqp, MStore CStash+                     , MOwned, MLore SItem ]+      plausiblyFlies = dmode == MLore SBlast+      tspeed | not (plausiblyThrown || plausiblyFlies) = ""+             | speed < speedLimp =+               if plausiblyThrown+               then "When thrown, it drops at once."+               else "When airborne, it drops at once."+             | speed < speedWalk =+               if plausiblyThrown+               then "When thrown, it drops after one meter."+               else "When airborne, it drops after one meter."+             | otherwise =+               (if plausiblyThrown+                then "Can be thrown at"+                else "Travels at")+               <+> T.pack (displaySpeed $ fromSpeed speed)+               <> (if throwLinger /= 100+                   then let trange = if range == 0+                                     then "immediately"+                                     else "after" <+> tshow range <> "m"+                        in " dropping" <+> trange+                             -- comma here is logical but looks bad+                   else "")+               <> "."+      tsuspect = ["You are unsure what it does." | itemSuspect]+      (desc, aspectSentences, damageAnalysis) =+        let aspects = case itemDisco of+              ItemDiscoMean IA.KindMean{..} | kmConst ->+                IA.aspectRecordToList kmMean  -- exact and collated+              ItemDiscoMean{} -> IK.iaspects itemKind+                -- doesn't completely lose the @Odds@ case, so better than+                -- the above, even if does not collate multiple skill bonuses+              ItemDiscoFull iAspect -> IA.aspectRecordToList iAspect+            sentences = tsuspect ++ mapMaybe aspectToSentence aspects+            aHurtMeleeOfItem = IA.getSkill Ability.SkHurtMelee arItem+            meanDmg = ceiling $ Dice.meanDice (IK.idamage itemKind)+            dmgAn = if meanDmg <= 0 then "" else+              let multRaw = aHurtMeleeOfOwner+                            + if dmode `elem` [MStore CEqp, MStore COrgan]+                              then 0+                              else aHurtMeleeOfItem+                  mult = 100 + min 100 (max (-95) multRaw)+                  percentDeltaHP = xM meanDmg `divUp` 100+                  rawDeltaHP = into @Int64 mult * percentDeltaHP+                  pmult = 100 + min 100 (max (-95) aHurtMeleeOfItem)+                  prawDeltaHP = into @Int64 pmult * percentDeltaHP+                  pdeltaHP = modifyDamageBySpeed prawDeltaHP speed+                  minDeltaHP = 5 * percentDeltaHP+                  mDeltaHP = modifyDamageBySpeed minDeltaHP speed+              in+                "Against defenceless foes you'd inflict around"+                  -- rounding and non-id items+                <+> tshow meanDmg+                <> "*" <> tshow mult <> "%"+                <> "=" <> show64With2 rawDeltaHP+                <+> "melee damage (min" <+> show64With2 minDeltaHP <> ")"+                <+> (if pdeltaHP <= 0 then "" else+                       "and"+                       <+> tshow meanDmg+                       <> "*" <> tshow pmult <> "%"+                       <> "*" <> "speed^2"+                       <> "/" <> tshow (fromSpeed speedThrust+                                        `divUp` 10) <> "^2"+                       <> "=" <> show64With2 pdeltaHP+                       <+> "ranged damage (min" <+> show64With2 mDeltaHP <> ")")+                <+> "with it"+                <> if Dice.infDice (IK.idamage itemKind)+                      == Dice.supDice (IK.idamage itemKind)+                   then "."+                   else "on average."+        in (IK.idesc itemKind, T.intercalate " " sentences, tspeed <+> dmgAn)+      weight = IK.iweight itemKind+      (scaledWeight, unitWeight)+        | weight > 1000 =+          (tshow $ intToDouble weight / 1000, "kg")+        | otherwise = (tshow weight, "g")+      onLevel = "on level" <+> tshow (abs $ fromEnum jlid) <> "."+      discoFirst = (if IA.checkFlag Ability.Unique arItem+                    then "Discovered"+                    else "First seen")+                   <+> onLevel+      whose fid = gname (factionD EM.! fid)+      sourceDesc =+        case jfid itemBase of+          Just fid | IA.checkFlag Ability.Condition arItem ->+            "Caused by" <+> (if fid == side then "us" else whose fid)+            <> ". First observed" <+> onLevel+          Just fid ->+            "Coming from" <+> whose fid+            <> "." <+> discoFirst+          _ -> discoFirst+      -- Organs are almost always either empty or more than singular,+      -- so the "organs" below is fine. Also, some organs come in pairs+      -- or more, so we don't know the number without much more work,+      -- so @squashedWWandW@ would be out of place. Also, mentioning+      -- two hands and two legs is not that enlightening and the number+      -- is not shown in organ lore, so this should wait until we add+      -- proper hyperlinks both ways instead of relying of names.+      ikitToPart = MU.Text . T.intercalate ", " . map (displayGroupName . fst)+      (ikitOrganNames, ikitOtherNames) =+        partition ((== COrgan) . snd) $ IK.ikit itemKind+      ikitDesc | null ikitOrganNames = ""+               | otherwise =+        makeSentence+          [ "the actor has organs of this kind:"+          , ikitToPart ikitOrganNames ]+        <> if null ikitOtherNames+           then ""+           else "\n\n"+                <> makeSentence+                     [ "the actor starts in possession of the following:"+                     , ikitToPart ikitOtherNames ]+      colorSymbol = viewItem itemFull+      blurb =+       (((" "+          <> npowers+          <> (if markParagraphs then "\n\n" else " ")+          <> T.intercalate "\n\n" orTs+          <> (if markParagraphs && not (null orTs) then "\n\n" else "")+          <> desc+          <> (if markParagraphs && not (T.null desc) then "\n\n" else ""))+        <+> (if weight > 0+             then makeSentence+                    ["Weighs around", MU.Text scaledWeight <> unitWeight]+             else ""))+        <+> aspectSentences+        <+> sourceDesc+        <+> damageAnalysis)+       <> (if markParagraphs && not (T.null ikitDesc) then "\n\n" else "\n")+       <> ikitDesc+  in colorSymbol : textToAS blurb
+ engine-src/Game/LambdaHack/Client/UI/Key.hs view
@@ -0,0 +1,563 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Frontend-independent keyboard input operations.+module Game.LambdaHack.Client.UI.Key+  ( Key(..), Modifier(..), KM(..), KMP(..)+  , showKey, showKM+  , escKM, controlEscKM, spaceKM, safeSpaceKM, undefinedKM, returnKM+  , pgupKM, pgdnKM, wheelNorthKM, wheelSouthKM+  , upKM, downKM, leftKM, rightKM+  , homeKM, endKM, backspaceKM, controlP+  , leftButtonReleaseKM, middleButtonReleaseKM, rightButtonReleaseKM+  , cardinalAllKM, dirAllKey, handleCardinal, handleDir, moveBinding+  , mkKM, mkChar, keyTranslate, keyTranslateWeb+  , dirMoveNoModifier, dirRunNoModifier, dirRunControl, dirRunShift+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , dirKeypadKey, dirKeypadShiftChar, dirKeypadShiftKey+  , dirLeftHandKey, dirLeftHandShiftKey+  , dirViChar, dirViKey, dirViShiftKey+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude hiding (Left, Right)++import           Control.DeepSeq+import           Data.Binary+import qualified Data.Char as Char+import           GHC.Generics (Generic)++import Game.LambdaHack.Client.UI.PointUI+import Game.LambdaHack.Common.Vector++-- | Frontend-independent datatype to represent keys.+data Key =+    Esc+  | Return+  | Space+  | Tab+  | BackTab+  | BackSpace+  | PgUp+  | PgDn+  | Left+  | Right+  | Up+  | Down+  | End+  | Begin+  | Insert+  | Delete+  | PrintScreen+  | Home+  | KP Char      -- ^ a keypad key for a character (digits and operators)+  | Char Char    -- ^ a single printable character+  | Fun Int      -- ^ function key+  | LeftButtonPress    -- ^ left mouse button pressed+  | MiddleButtonPress  -- ^ middle mouse button pressed+  | RightButtonPress   -- ^ right mouse button pressed+  | LeftButtonRelease    -- ^ left mouse button released+  | MiddleButtonRelease  -- ^ middle mouse button released+  | RightButtonRelease   -- ^ right mouse button released+  | WheelNorth  -- ^ mouse wheel rotated north+  | WheelSouth  -- ^ mouse wheel rotated south+  | Unknown String -- ^ an unknown key, registered to warn the user+  | DeadKey+  deriving (Ord, Eq, Generic)++instance Binary Key++instance NFData Key++-- | Our own encoding of modifiers.+data Modifier =+    NoModifier+  | ControlShift+  | AltShift+  | Shift+  | Control+  | Alt+  deriving (Show, Ord, Eq, Generic)++instance Binary Modifier++instance NFData Modifier++-- | Key and modifier.+data KM = KM { modifier :: Modifier+             , key      :: Key }+  deriving (Ord, Eq, Generic)++instance Binary KM++instance NFData KM++instance Show KM where+  show = showKM++-- | Key, modifier and position of mouse pointer.+data KMP = KMP { kmpKeyMod  :: KM+               , kmpPointer :: PointUI }++-- | Common and terse names for keys.+showKey :: Key -> String+showKey Esc      = "ESC"+showKey Return   = "RET"+showKey Space    = "SPACE"+showKey Tab      = "TAB"+showKey BackTab  = "S-TAB"+showKey BackSpace = "BACKSPACE"+showKey Up       = "UP"+showKey Down     = "DOWN"+showKey Left     = "LEFT"+showKey Right    = "RIGHT"+showKey Home     = "HOME"+showKey End      = "END"+showKey PgUp     = "PGUP"+showKey PgDn     = "PGDN"+showKey Begin    = "BEGIN"+showKey Insert   = "INS"+showKey Delete   = "DEL"+showKey PrintScreen = "PRTSCR"+showKey (KP c)   = "KP_" ++ [c]+showKey (Char c) = [c]+showKey (Fun n) = "F" ++ show n+showKey LeftButtonPress = "LMB-PRESS"+showKey MiddleButtonPress = "MMB-PRESS"+showKey RightButtonPress = "RMB-PRESS"+showKey LeftButtonRelease = "LMB"+showKey MiddleButtonRelease = "MMB"+showKey RightButtonRelease = "RMB"+showKey WheelNorth = "WHEEL-UP"+showKey WheelSouth = "WHEEL-DN"+showKey (Unknown s) = s+showKey DeadKey      = "DEADKEY"++-- | Show a key with a modifier, if any.+showKM :: KM -> String+showKM KM{modifier=NoModifier, key} = showKey key+showKM KM{modifier=ControlShift, key} = "C-S-" ++ showKey key+showKM KM{modifier=AltShift, key} = "A-S-" ++ showKey key+showKM KM{modifier=Shift, key} = "S-" ++ showKey key+showKM KM{modifier=Control, key} = "C-" ++ showKey key+showKM KM{modifier=Alt, key} = "A-" ++ showKey key++escKM :: KM+escKM = KM NoModifier Esc++controlEscKM :: KM+controlEscKM = KM Control Esc++spaceKM :: KM+spaceKM = KM NoModifier Space++safeSpaceKM :: KM+safeSpaceKM = KM NoModifier $ Unknown "SAFE_SPACE"++undefinedKM :: KM+undefinedKM = KM NoModifier $ Unknown "UNDEFINED KEY"++returnKM :: KM+returnKM = KM NoModifier Return++pgupKM :: KM+pgupKM = KM NoModifier PgUp++pgdnKM :: KM+pgdnKM = KM NoModifier PgDn++wheelNorthKM :: KM+wheelNorthKM = KM NoModifier WheelNorth++wheelSouthKM :: KM+wheelSouthKM = KM NoModifier WheelSouth++upKM :: KM+upKM = KM NoModifier Up++downKM :: KM+downKM = KM NoModifier Down++leftKM :: KM+leftKM = KM NoModifier Left++rightKM :: KM+rightKM = KM NoModifier Right++homeKM :: KM+homeKM = KM NoModifier Home++endKM :: KM+endKM = KM NoModifier End++backspaceKM :: KM+backspaceKM = KM NoModifier BackSpace++controlP :: KM+controlP = KM Control (Char 'P')++leftButtonReleaseKM :: KM+leftButtonReleaseKM = KM NoModifier LeftButtonRelease++middleButtonReleaseKM :: KM+middleButtonReleaseKM = KM NoModifier MiddleButtonRelease++rightButtonReleaseKM :: KM+rightButtonReleaseKM = KM NoModifier RightButtonRelease++cardinalKeypadKM :: [KM]+cardinalKeypadKM = map (KM NoModifier) [Up, Right, Down, Left]++dirKeypadKey :: [Key]+dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]++dirKeypadShiftChar :: [Char]+dirKeypadShiftChar = ['7', '8', '9', '6', '3', '2', '1', '4']++dirKeypadShiftKey :: [Key]+dirKeypadShiftKey = map KP dirKeypadShiftChar++cardinalLeftHandKM :: [KM]+cardinalLeftHandKM = map (KM NoModifier . Char) ['w', 'd', 'x', 'a']++dirLeftHandKey :: [Key]+dirLeftHandKey = map Char ['q', 'w', 'e', 'd', 'c', 'x', 'z', 'a']++dirLeftHandShiftKey :: [Key]+dirLeftHandShiftKey = map Char ['Q', 'W', 'E', 'D', 'C', 'X', 'Z', 'A']++cardinalViKM :: [KM]+cardinalViKM = map (KM NoModifier . Char) ['k', 'l', 'j', 'h']++dirViChar :: [Char]+dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']++dirViKey :: [Key]+dirViKey = map Char dirViChar++dirViShiftKey :: [Key]+dirViShiftKey = map (Char . Char.toUpper) dirViChar++dirMoveNoModifier :: Bool -> Bool -> [Key]+dirMoveNoModifier uVi uLeftHand =+  dirKeypadKey ++ (if uVi then dirViKey else [])+               ++ (if uLeftHand then dirLeftHandKey else [])++dirRunNoModifier :: Bool -> Bool -> [Key]+dirRunNoModifier uVi uLeftHand =+  dirKeypadShiftKey ++ (if uVi then dirViShiftKey else [])+                    ++ (if uLeftHand then dirLeftHandShiftKey else [])++dirRunControl :: [Key]+dirRunControl = dirKeypadKey+                ++ dirKeypadShiftKey+                ++ map Char dirKeypadShiftChar++dirRunShift :: [Key]+dirRunShift = dirRunControl++cardinalAllKM :: Bool -> Bool -> [KM]+cardinalAllKM uVi uLeftHand = concat $+  [cardinalKeypadKM]+  ++ [cardinalViKM | uVi]+  ++ [cardinalLeftHandKM | uLeftHand]++dirAllKey :: Bool -> Bool -> [Key]+dirAllKey uVi uLeftHand =+  dirMoveNoModifier uVi uLeftHand+  ++ dirRunNoModifier uVi uLeftHand+  ++ dirRunControl++handleCardinal :: [KM] -> KM -> Maybe Vector+handleCardinal dirKeys key =+  let assocs = zip dirKeys $ cycle movesCardinal+  in lookup key assocs++-- | Configurable event handler for the direction keys.+-- Used for directed commands such as close door.+handleDir :: [Key] -> KM -> Maybe Vector+handleDir dirKeys KM{modifier=NoModifier, key} =+  let assocs = zip dirKeys $ cycle moves+  in lookup key assocs+handleDir _ _ = Nothing++-- | Binding of both sets of movement keys, vi and laptop.+moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a)+            -> [(KM, a)]+moveBinding uVi uLeftHand move run =+  let assign f km dir = (km, f dir)+      mapMove modifier keys =+        zipWith (assign move) (map (KM modifier) keys) (cycle moves)+      mapRun modifier keys =+        zipWith (assign run) (map (KM modifier) keys) (cycle moves)+  in mapMove NoModifier (dirMoveNoModifier uVi uLeftHand)+     ++ mapRun NoModifier (dirRunNoModifier uVi uLeftHand)+     ++ mapRun Control dirRunControl+     ++ mapRun Shift dirRunShift++mkKM :: String -> KM+mkKM s = let mkKey sk =+               case keyTranslate sk of+                 Unknown _ -> error $ "unknown key" `showFailure` s+                 key -> key+         in case s of+           'C':'-':'S':'-':rest -> KM ControlShift (mkKey rest)+           'S':'-':'C':'-':rest -> KM ControlShift (mkKey rest)+           'A':'-':'S':'-':rest -> KM AltShift (mkKey rest)+           'S':'-':'A':'-':rest -> KM AltShift (mkKey rest)+           'S':'-':rest -> KM Shift (mkKey rest)+           'C':'-':rest -> KM Control (mkKey rest)+           'A':'-':rest -> KM Alt (mkKey rest)+           _ -> KM NoModifier (mkKey s)++mkChar :: Char -> KM+mkChar c = KM NoModifier $ Char c++-- | Translate key from a GTK string description to our internal key type.+-- To be used, in particular, for the command bindings and macros+-- in the config file.+--+-- See <https://github.com/twobob/gtk-/blob/master/gdk/keynames.txt>+keyTranslate :: String -> Key+keyTranslate "less"          = Char '<'+keyTranslate "greater"       = Char '>'+keyTranslate "period"        = Char '.'+keyTranslate "colon"         = Char ':'+keyTranslate "semicolon"     = Char ';'+keyTranslate "comma"         = Char ','+keyTranslate "question"      = Char '?'+keyTranslate "numbersign"    = Char '#'+keyTranslate "dollar"        = Char '$'+keyTranslate "parenleft"     = Char '('+keyTranslate "parenright"    = Char ')'+keyTranslate "asterisk"      = Char '*'  -- KP and normal are merged here+keyTranslate "KP_Multiply"   = Char '*'+keyTranslate "slash"         = Char '/'+keyTranslate "KP_Divide"     = Char '/'+keyTranslate "bar"           = Char '|'+keyTranslate "backslash"     = Char '\\'+keyTranslate "asciicircum"   = Char '^'+keyTranslate "underscore"    = Char '_'+keyTranslate "minus"         = Char '-'+keyTranslate "KP_Subtract"   = Char '-'  -- KP and normal are merged here+keyTranslate "plus"          = Char '+'+keyTranslate "KP_Add"        = Char '+'  -- KP and normal are merged here+keyTranslate "equal"         = Char '='+keyTranslate "bracketleft"   = Char '['+keyTranslate "bracketright"  = Char ']'+keyTranslate "braceleft"     = Char '{'+keyTranslate "braceright"    = Char '}'+keyTranslate "caret"         = Char '^'+keyTranslate "ampersand"     = Char '&'+keyTranslate "at"            = Char '@'+keyTranslate "asciitilde"    = Char '~'+keyTranslate "grave"         = Char '`'+keyTranslate "exclam"        = Char '!'+keyTranslate "apostrophe"    = Char '\''+keyTranslate "quotedbl"      = Char '"'+keyTranslate "Escape"        = Esc+keyTranslate "ESC"           = Esc+keyTranslate "Return"        = Return+keyTranslate "RET"           = Return+keyTranslate "space"         = Space+keyTranslate "SPACE"         = Space+keyTranslate "Tab"           = Tab+keyTranslate "TAB"           = Tab+keyTranslate "BackTab"       = BackTab+keyTranslate "ISO_Left_Tab"  = BackTab+keyTranslate "BackSpace"     = BackSpace+keyTranslate "BACKSPACE"     = BackSpace+keyTranslate "Up"            = Up+keyTranslate "UP"            = Up+keyTranslate "KP_Up"         = Up+keyTranslate "Down"          = Down+keyTranslate "DOWN"          = Down+keyTranslate "KP_Down"       = Down+keyTranslate "Left"          = Left+keyTranslate "LEFT"          = Left+keyTranslate "KP_Left"       = Left+keyTranslate "Right"         = Right+keyTranslate "RIGHT"         = Right+keyTranslate "KP_Right"      = Right+keyTranslate "Home"          = Home+keyTranslate "HOME"          = Home+keyTranslate "KP_Home"       = Home+keyTranslate "End"           = End+keyTranslate "END"           = End+keyTranslate "KP_End"        = End+keyTranslate "Page_Up"       = PgUp+keyTranslate "PGUP"          = PgUp+keyTranslate "KP_Page_Up"    = PgUp+keyTranslate "Prior"         = PgUp+keyTranslate "KP_Prior"      = PgUp+keyTranslate "Page_Down"     = PgDn+keyTranslate "PGDN"          = PgDn+keyTranslate "KP_Page_Down"  = PgDn+keyTranslate "Next"          = PgDn+keyTranslate "KP_Next"       = PgDn+keyTranslate "Begin"         = Begin+keyTranslate "BEGIN"         = Begin+keyTranslate "KP_Begin"      = Begin+keyTranslate "Clear"         = Begin+keyTranslate "KP_Clear"      = Begin+keyTranslate "Center"        = Begin+keyTranslate "KP_Center"     = Begin+keyTranslate "Insert"        = Insert+keyTranslate "INS"           = Insert+keyTranslate "KP_Insert"     = Insert+keyTranslate "Delete"        = Delete+keyTranslate "DEL"           = Delete+keyTranslate "KP_Delete"     = Delete+keyTranslate "KP_Enter"      = Return+keyTranslate "F1"            = Fun 1+keyTranslate "F2"            = Fun 2+keyTranslate "F3"            = Fun 3+keyTranslate "F4"            = Fun 4+keyTranslate "F5"            = Fun 5+keyTranslate "F6"            = Fun 6+keyTranslate "F7"            = Fun 7+keyTranslate "F8"            = Fun 8+keyTranslate "F9"            = Fun 9+keyTranslate "F10"           = Fun 10+keyTranslate "F11"           = Fun 11+keyTranslate "F12"           = Fun 12+keyTranslate "LeftButtonPress" = LeftButtonPress+keyTranslate "LMB-PRESS" = LeftButtonPress+keyTranslate "MiddleButtonPress" = MiddleButtonPress+keyTranslate "MMB-PRESS" = MiddleButtonPress+keyTranslate "RightButtonPress" = RightButtonPress+keyTranslate "RMB-PRESS" = RightButtonPress+keyTranslate "LeftButtonRelease" = LeftButtonRelease+keyTranslate "LMB" = LeftButtonRelease+keyTranslate "MiddleButtonRelease" = MiddleButtonRelease+keyTranslate "MMB" = MiddleButtonRelease+keyTranslate "RightButtonRelease" = RightButtonRelease+keyTranslate "RMB" = RightButtonRelease+keyTranslate "WheelNorth"    = WheelNorth+keyTranslate "WHEEL-UP"      = WheelNorth+keyTranslate "WheelSouth"    = WheelSouth+keyTranslate "WHEEL-DN"      = WheelSouth+-- dead keys+keyTranslate "Shift_L"          = DeadKey+keyTranslate "Shift_R"          = DeadKey+keyTranslate "Control_L"        = DeadKey+keyTranslate "Control_R"        = DeadKey+keyTranslate "Super_L"          = DeadKey+keyTranslate "Super_R"          = DeadKey+keyTranslate "Menu"             = DeadKey+keyTranslate "Alt_L"            = DeadKey+keyTranslate "Alt_R"            = DeadKey+keyTranslate "Meta_L"           = DeadKey+keyTranslate "Meta_R"           = DeadKey+keyTranslate "ISO_Level2_Shift" = DeadKey+keyTranslate "ISO_Level3_Shift" = DeadKey+keyTranslate "ISO_Level2_Latch" = DeadKey+keyTranslate "ISO_Level3_Latch" = DeadKey+keyTranslate "Num_Lock"         = DeadKey+keyTranslate "NumLock"          = DeadKey+keyTranslate "Caps_Lock"        = DeadKey+keyTranslate "CapsLock"         = DeadKey+keyTranslate "VoidSymbol"       = DeadKey+-- numeric keypad+keyTranslate ['K','P','_',c] = KP c+-- standard characters+keyTranslate [c]             = Char c+keyTranslate s               = Unknown s++-- | Translate key from a Web API string description+-- (<https://developer.mozilla.org/en-US/docs/Web/API/KeyboardEvent/key#Key_values>)+-- to our internal key type. To be used in web frontends.+-- The argument says whether Shift is pressed.+keyTranslateWeb :: String -> Bool -> Key+keyTranslateWeb "1"          True = KP '1'+keyTranslateWeb "2"          True = KP '2'+keyTranslateWeb "3"          True = KP '3'+keyTranslateWeb "4"          True = KP '4'+keyTranslateWeb "5"          True = KP '5'+keyTranslateWeb "6"          True = KP '6'+keyTranslateWeb "7"          True = KP '7'+keyTranslateWeb "8"          True = KP '8'+keyTranslateWeb "9"          True = KP '9'+keyTranslateWeb "End"        True = KP '1'+keyTranslateWeb "ArrowDown"  True = KP '2'+keyTranslateWeb "PageDown"   True = KP '3'+keyTranslateWeb "ArrowLeft"  True = KP '4'+keyTranslateWeb "Begin"      True = KP '5'+keyTranslateWeb "Clear"      True = KP '5'+keyTranslateWeb "ArrowRight" True = KP '6'+keyTranslateWeb "Home"       True = KP '7'+keyTranslateWeb "ArrowUp"    True = KP '8'+keyTranslateWeb "PageUp"     True = KP '9'+keyTranslateWeb "Backspace"  _ = BackSpace+keyTranslateWeb "Tab"        True = BackTab+keyTranslateWeb "Tab"        False = Tab+keyTranslateWeb "BackTab"    _ = BackTab+keyTranslateWeb "Begin"      _ = Begin+keyTranslateWeb "Clear"      _ = Begin+keyTranslateWeb "Enter"      _ = Return+keyTranslateWeb "Esc"        _ = Esc+keyTranslateWeb "Escape"     _ = Esc+keyTranslateWeb "Del"        _ = Delete+keyTranslateWeb "Delete"     _ = Delete+keyTranslateWeb "Home"       _ = Home+keyTranslateWeb "Up"         _ = Up+keyTranslateWeb "ArrowUp"    _ = Up+keyTranslateWeb "Down"       _ = Down+keyTranslateWeb "ArrowDown"  _ = Down+keyTranslateWeb "Left"       _ = Left+keyTranslateWeb "ArrowLeft"  _ = Left+keyTranslateWeb "Right"      _ = Right+keyTranslateWeb "ArrowRight" _ = Right+keyTranslateWeb "PageUp"     _ = PgUp+keyTranslateWeb "PageDown"   _ = PgDn+keyTranslateWeb "End"        _ = End+keyTranslateWeb "Insert"     _ = Insert+keyTranslateWeb "space"      _ = Space+keyTranslateWeb "Equals"     _ = Char '='+keyTranslateWeb "Multiply"   _ = Char '*'  -- KP and normal are merged here+keyTranslateWeb "*"          _ = Char '*'+keyTranslateWeb "Add"        _ = Char '+'  -- KP and normal are merged here+keyTranslateWeb "Subtract"   _ = Char '-'  -- KP and normal are merged here+keyTranslateWeb "Divide"     True = Char '?'+keyTranslateWeb "Divide"     False = Char '/' -- KP and normal are merged here+keyTranslateWeb "/"          True = Char '?'+keyTranslateWeb "/"          False = Char '/' -- KP and normal are merged here+keyTranslateWeb "Decimal"    _ = Char '.'  -- dot and comma are merged here+keyTranslateWeb "Separator"  _ = Char '.'  -- to sidestep national standards+keyTranslateWeb "F1"         _ = Fun 1+keyTranslateWeb "F2"         _ = Fun 2+keyTranslateWeb "F3"         _ = Fun 3+keyTranslateWeb "F4"         _ = Fun 4+keyTranslateWeb "F5"         _ = Fun 5+keyTranslateWeb "F6"         _ = Fun 6+keyTranslateWeb "F7"         _ = Fun 7+keyTranslateWeb "F8"         _ = Fun 8+keyTranslateWeb "F9"         _ = Fun 9+keyTranslateWeb "F10"        _ = Fun 10+keyTranslateWeb "F11"        _ = Fun 11+keyTranslateWeb "F12"        _ = Fun 12+-- dead keys+keyTranslateWeb "Dead"        _ = DeadKey+keyTranslateWeb "Shift"       _ = DeadKey+keyTranslateWeb "Control"     _ = DeadKey+keyTranslateWeb "Meta"        _ = DeadKey+keyTranslateWeb "Menu"        _ = DeadKey+keyTranslateWeb "ContextMenu" _ = DeadKey+keyTranslateWeb "Alt"         _ = DeadKey+keyTranslateWeb "AltGraph"    _ = DeadKey+keyTranslateWeb "Num_Lock"    _ = DeadKey+keyTranslateWeb "NumLock"     _ = DeadKey+keyTranslateWeb "Caps_Lock"   _ = DeadKey+keyTranslateWeb "CapsLock"    _ = DeadKey+keyTranslateWeb "Win"         _ = DeadKey+-- browser quirks+keyTranslateWeb "Unidentified" _ = Begin  -- hack for Firefox+keyTranslateWeb ['\ESC']     _ = Esc+keyTranslateWeb [' ']        _ = Space+keyTranslateWeb ['\n']       _ = Return+keyTranslateWeb ['\r']       _ = DeadKey+keyTranslateWeb ['\t']       _ = Tab+-- standard characters+keyTranslateWeb [c]          _ = Char c+keyTranslateWeb s            _ = Unknown s
+ engine-src/Game/LambdaHack/Client/UI/KeyBindings.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE RankNTypes #-}+-- | Verifying, aggregating and displaying binding of keys to commands.+module Game.LambdaHack.Client.UI.KeyBindings+  ( keyHelp, okxsN+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.Map.Strict as M+import qualified Data.Text as T++import           Game.LambdaHack.Client.UI.Content.Input+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Client.UI.Slideshow+import qualified Game.LambdaHack.Definition.Color as Color++-- | Produce a set of help/menu screens from the key bindings.+--+-- When the intro screen mentions KP_5, this really is KP_Begin,+-- but since that is harder to understand we assume a different, non-default+-- state of NumLock in the help text than in the code that handles keys.+keyHelp :: CCUI -> FontSetup -> [(Text, OKX)]+keyHelp CCUI{ coinput=coinput@InputContent{..}+            , coscreen=ScreenContent{rwidth, rheight} } FontSetup{..} =+  let+    movBlurb1 =+      [ "Walk throughout a level with mouse or numeric keypad (right diagram below)"+      , "or the Vi editor keys (middle) or the left-hand movement keys (left). Run until"+      , "disturbed with Shift or Control. Go-to a position with LMB (left mouse button)."+      , "In aiming mode, the same keys (and mouse) move the aiming crosshair."+      ]+    movSchema =+      [ "     q w e     y k u     7 8 9"+      , "      \\|/       \\|/       \\|/"+      , "     a-s-d     h-.-l     4-5-6"+      , "      /|\\       /|\\       /|\\"+      , "     z x c     b j n     1 2 3"+      ]+    movBlurb2 =+      [ "Press `KP_5` (`5` on keypad) to wait, bracing for impact, which reduces any"+      , "damage taken and prevents displacement by foes. Press `S-KP_5` or `C-KP_5`"+      , "(the same key with Shift or Control) to lurk 0.1 of a turn, without bracing."+      , ""+      , "Displace enemies by running into them with Shift/Control or S-LMB. Search,"+      , "open, descend and melee by bumping into walls, doors, stairs and enemies."+      , "The best, and not on cooldown, melee weapon is automatically chosen"+      , "for attack from your equipment and from among your body parts."+      ]+    minimalBlurb =+      [ "The following few commands, joined with the movement and running keys,"+      , "let you accomplish almost anything in the game, though not necessarily"+      , "with the fewest keystrokes. You can also play the game exclusively"+      , "with a mouse, or both mouse and keyboard (e.g., mouse for go-to"+      , "and terrain inspection and keyboard for everything else). Lastly,"+      , "you can select a command with arrows or mouse directly from the help"+      , "screen or the dashboard and execute it on the spot."+      ]+    itemAllEnding =+      [ "Note how lower case item commands (stash item, equip item) place items"+      , "into a particular item store, while upper case item commands (manage Inventory,"+      , "manage Outfit) open management menu for a store. Once a store menu is opened,"+      , "you can switch stores with `<` and `>`, so the multiple commands only determine"+      , "the starting item store. Each store is accessible from the dashboard as well."+      ]+    mouseBasicsBlurb =+      [ "Screen area and UI mode (exploration/aiming) determine mouse click"+      , "effects. Here we give an overview of effects of each button over"+      , "the game map area. The list includes not only left and right buttons,"+      , "but also the optional middle mouse button (MMB) and the mouse wheel,"+      , "which is also used over menus to move selection. For mice without RMB,"+      , "one can use Control key with LMB and for mice without MMB, one can use"+      , "C-RMB or C-S-LMB."+      ]+    mouseAreasBlurb =+      [ "Next we show mouse button effects per screen area, in exploration and"+      , "(if different) aiming mode. Note that mouse is optional. Keyboard suffices,"+      , "occasionally requiring a lookup for an obscure command key in help screens."+      ]+    mouseAreasMini =+      [ "Mouse button effects per screen area, in exploration and in aiming modes"+      ]+    movTextEnd = "Press SPACE or PGDN to advance or ESC to see the map again."+    lastHelpEnd = "Use PGUP to go back and ESC to see the map again."+    seeAlso = "For more playing instructions see file PLAYING.md."+    offsetCol2 = 12+    pickLeaderDescription =+      [ fmt offsetCol2 "0, 1 ... 9"+                       "pick a particular actor as the new pointman"+      ]+    casualDescription = "Minimal cheat sheet for casual play"+    fmt0 n k h = T.justifyLeft n ' ' k <> " " <> h+    fmt n k h = " " <> fmt0 n k h+    keyCaption = fmt offsetCol2 "keys" "command"+    mouseOverviewCaption = fmt offsetCol2 "keys" "command (exploration/aiming)"+    spLen = textSize monoFont " "+    okxs cat headers footers = xytranslateOKX spLen 0 $+      okxsN coinput monoFont propFont offsetCol2 (const False)+            True cat headers footers+    mergeOKX :: OKX -> OKX -> OKX+    mergeOKX okx1 okx2 =+      let off = 1 + maxYofFontOverlayMap (fst okx1)+      in sideBySideOKX 0 off okx1 okx2+    catLength cat = length $ filter (\(_, (cats, desc, _)) ->+      cat `elem` cats && (desc /= "" || CmdInternal `elem` cats)) bcmdList+    keyM = 13+    keyB = 31+    truncatem b = if T.length b > keyB+                  then T.take (keyB - 1) b <> "$"+                  else b+    fmm a b c = fmt (keyM + 1) a $ fmt0 keyB (truncatem b) (truncatem c)+    areaCaption t = fmm t "LMB (left mouse button)" "RMB (right mouse button)"+    keySel :: (forall a. (a, a) -> a) -> K.KM+           -> [(CmdArea, KeyOrSlot, Text)]+    keySel sel key =+      let cmd = case M.lookup key bcmdMap of+            Just (_, _, cmd2) -> cmd2+            Nothing -> error $ "" `showFailure` key+          caCmds = case cmd of+            ByAimMode AimModeCmd{exploration=ByArea lexp, aiming=ByArea laim} ->+              sort $ sel (lexp, laim \\ lexp)+            _ -> error $ "" `showFailure` cmd+          caMakeChoice (ca, cmd2) =+            let (km, desc) = case M.lookup cmd2 brevMap of+                  Just ks ->+                    let descOfKM km2 = case M.lookup km2 bcmdMap of+                          Just (_, "", _) -> Nothing+                          Just (_, desc2, _) -> Just (km2, desc2)+                          Nothing -> error $ "" `showFailure` km2+                    in case mapMaybe descOfKM ks of+                      [] -> error $ "" `showFailure` (ks, cmd2)+                      kmdesc3 : _ -> kmdesc3+                  Nothing -> (key, "(not described:" <+> tshow cmd2 <> ")")+            in (ca, Left km, desc)+      in map caMakeChoice caCmds+    doubleIfSquare n | isSquareFont monoFont = 2 * n+                     | otherwise = n+    okm :: (forall a. (a, a) -> a) -> K.KM -> K.KM -> [Text] -> OKX+    okm sel key1 key2 header =+      let kst1 = keySel sel key1+          kst2 = keySel sel key2+          f (ca1, Left km1, _) (ca2, Left km2, _) y =+            assert (ca1 == ca2 `blame` (ca1, ca2, km1, km2, kst1, kst2))+              [ (Left km1, ( PointUI (doubleIfSquare $ keyM + 4) y+                           , ButtonWidth monoFont keyB ))+              , (Left km2, ( PointUI (doubleIfSquare $ keyB + keyM + 5) y+                           , ButtonWidth monoFont keyB )) ]+          f c d e = error $ "" `showFailure` (c, d, e)+          kxs = concat $ zipWith3 f kst1 kst2 [1 + length header..]+          menuLeft = map (\(ca1, _, _) -> textToAL $ areaDescription ca1) kst1+          menuMiddle = map (\(_, _, desc) -> textToAL desc) kst1+          menuRight = map (\(_, _, desc) -> textToAL desc) kst2+          y0 = 1 + length header+      in ( EM.unionsWith (++)+             [ typesetInMono $ "" : header+             , EM.singleton monoFont+               $ typesetXY (doubleIfSquare 2, y0) menuLeft+             , EM.singleton propFont+               $ typesetXY (doubleIfSquare $ keyM + 4, y0) menuMiddle+             , EM.singleton propFont+               $ typesetXY (doubleIfSquare $ keyB + keyM + 5, y0) menuRight ]+         , kxs )+    typesetInSquare :: [Text] -> FontOverlayMap+    typesetInSquare =+      EM.singleton squareFont . typesetXY (spLen, 0) . map textToAL+    typesetInMono :: [Text] -> FontOverlayMap+    typesetInMono =+      EM.singleton monoFont . typesetXY (spLen, 0) . map textToAL+    typesetInProp :: [Text] -> FontOverlayMap+    typesetInProp =+      EM.singleton propFont . typesetXY (spLen, 0) . map textToAL+    sideBySide :: [(Text, OKX)] -> [(Text, OKX)]+    sideBySide ((_t1, okx1) : (t2, okx2) : rest) | not (isSquareFont propFont) =+      (t2, sideBySideOKX rwidth 0 okx1 okx2) : sideBySide rest+    sideBySide l = l+  in sideBySide $ concat+    [ if catLength CmdMinimal+         + length movBlurb1 + length movSchema + length movBlurb2+         + length minimalBlurb+         + 6 > rheight then+        [ ( movTextEnd+          , mergeOKX+              (mergeOKX ( typesetInMono ["", casualDescription <+> "(1/2)", ""]+                        , [] )+                        (mergeOKX (typesetInProp movBlurb1, [])+                                  (typesetInSquare $ "" : movSchema, [])))+              (typesetInProp $ "" : movBlurb2, []) )+        , ( movTextEnd+          , okxs CmdMinimal+                 ( ["", casualDescription <+> "(2/2)", ""]+                 , minimalBlurb ++ [""]+                 , [keyCaption] )+                 ([], []) ) ]+      else+        [ ( movTextEnd+          , mergeOKX+              (mergeOKX ( typesetInMono ["", casualDescription, ""]+                        , [] )+                        (mergeOKX (typesetInProp movBlurb1, [])+                                  (typesetInSquare $ "" : movSchema, [])))+              (okxs CmdMinimal+                    ( []+                    , [""] ++ movBlurb2 ++ [""]+                       ++ minimalBlurb ++ [""]+                    , [keyCaption] )+                    ([], [""])) ) ]+    , if 45 > rheight then+        [ ( movTextEnd+          , let (ls, _) = okxs CmdMouse+                               ( ["", "Optional mouse commands", ""]+                               , mouseBasicsBlurb ++ [""]+                               , [mouseOverviewCaption] )+                               ([], [])+            in (ls, []) )  -- don't capture mouse wheel, etc.+        , ( movTextEnd+          , mergeOKX+              (typesetInMono $ "" : mouseAreasMini, [])+              (mergeOKX+                 (okm fst K.leftButtonReleaseKM K.rightButtonReleaseKM+                      [areaCaption "Exploration"])+                 (okm snd K.leftButtonReleaseKM K.rightButtonReleaseKM+                      [areaCaption "Aiming Mode"])) ) ]+      else+        [ ( movTextEnd+          , let (ls, _) = okxs CmdMouse+                               ( ["", "Optional mouse commands", ""]+                               , mouseBasicsBlurb ++ [""]+                               , [mouseOverviewCaption] )+                               ([], [])+                okx0 = (ls, [])  -- don't capture mouse wheel, etc.+            in mergeOKX+                 (mergeOKX+                    okx0+                    (typesetInProp $ "" : mouseAreasBlurb, []))+                 (mergeOKX+                    (okm fst K.leftButtonReleaseKM K.rightButtonReleaseKM+                         [areaCaption "Exploration"])+                    (okm snd K.leftButtonReleaseKM K.rightButtonReleaseKM+                         [areaCaption "Aiming Mode"] )) ) ]+    , if catLength CmdItem + catLength CmdMove + 9 + 9 > rheight then+        [ ( movTextEnd+          , okxs CmdItem+                 (["", categoryDescription CmdItem], [], ["", keyCaption])+                 ([], "" : itemAllEnding) )+        , ( movTextEnd+          , okxs CmdMove+                 (["", categoryDescription CmdMove], [], ["", keyCaption])+                 (pickLeaderDescription, []) ) ]+      else+        [ ( movTextEnd+          , mergeOKX+              (okxs CmdItem+                    (["", categoryDescription CmdItem], [], ["", keyCaption])+                    ([], "" : itemAllEnding))+              (okxs CmdMove+                    ( ["", "", categoryDescription CmdMove]+                    , []+                    , ["", keyCaption] )+                    (pickLeaderDescription, [""])) ) ]+    , if catLength CmdAim + catLength CmdMeta + 9 > rheight then+        [ ( movTextEnd+          , okxs CmdAim+                 (["", categoryDescription CmdAim], [], ["", keyCaption])+                 ([], []) )+        , ( lastHelpEnd+          , okxs CmdMeta+                 (["", categoryDescription CmdMeta], [], ["", keyCaption])+                 ([], ["", seeAlso]) ) ]+      else+        [ ( lastHelpEnd+          , mergeOKX+              (okxs CmdAim+                    (["", categoryDescription CmdAim], [], ["", keyCaption])+                    ([], []))+              (okxs CmdMeta+                    ( ["", "", categoryDescription CmdMeta]+                    , []+                    , ["", keyCaption] )+                    ([], ["", seeAlso, ""])) ) ]+    ]++-- | Turn the specified portion of bindings into a menu.+--+-- The length of the button may be wrong if the two supplied fonts+-- have very different widths.+okxsN :: InputContent -> DisplayFont -> DisplayFont -> Int -> (HumanCmd -> Bool)+      -> Bool -> CmdCategory -> ([Text], [Text], [Text]) -> ([Text], [Text])+      -> OKX+okxsN InputContent{..} labFont descFont offsetCol2 greyedOut+      showManyKeys cat (headerMono1, headerProp, headerMono2)+      (footerMono, footerProp) =+  let fmt k h = (T.singleton '\x00a0' <> k, h)+      coImage :: HumanCmd -> [K.KM]+      coImage cmd = M.findWithDefault (error $ "" `showFailure` cmd) cmd brevMap+      disp = T.intercalate " or " . map (T.pack . K.showKM)+      keyKnown km = case K.key km of+        K.Unknown{} -> False+        _ -> True+      keys :: [(KeyOrSlot, (Bool, (Text, Text)))]+      keys = [ (Left km, (greyedOut cmd, fmt keyNames desc))+             | (_, (cats, desc, cmd)) <- bcmdList+             , let kms = coImage cmd+                   knownKeys = filter keyKnown kms+                   keyNames =+                     disp $ (if showManyKeys then id else take 1) knownKeys+                   kmsRes = if desc == "" then knownKeys else kms+                   km = case kmsRes of+                     [] -> K.escKM+                     km1 : _ -> km1+             , cat `elem` cats+             , desc /= "" || CmdInternal `elem` cats]+      spLen = textSize labFont " "+      f (ks, (_, (_, t2))) y =+        (ks, ( PointUI spLen y+             , ButtonWidth labFont (offsetCol2 + 2 + T.length t2 - 1)))+      kxs = zipWith f keys+              [length headerMono1 + length headerProp + length headerMono2 ..]+      ts = map (\t -> (False, (t, ""))) headerMono1+           ++ map (\t -> (False, ("", t))) headerProp+           ++ map (\t -> (False, (t, ""))) headerMono2+           ++ map snd keys+           ++ map (\t -> (False, (t, ""))) footerMono+           ++ map (\t -> (False, ("", t))) footerProp+      greyToAL (b, (t1, t2)) =+        if b+        then let al1 = textFgToAL Color.BrBlack t1+             in (al1, ( if T.null t1 then 0 else spLen * (offsetCol2 + 2)+                      , textFgToAL Color.BrBlack t2 ))+        else let al1 = textToAL t1+             in (al1, ( if T.null t1 then 0 else spLen * (offsetCol2 + 2)+                      , textToAL t2 ))+      (greyLab, greyDesc) = unzip $ map greyToAL ts+  in ( EM.insertWith (++) descFont (offsetOverlayX greyDesc)+       $ EM.singleton labFont (offsetOverlay greyLab)+     , kxs )
+ engine-src/Game/LambdaHack/Client/UI/MonadClientUI.hs view
@@ -0,0 +1,498 @@+-- | Client monad for interacting with a human through UI.+module Game.LambdaHack.Client.UI.MonadClientUI+  ( -- * Client UI monad+    MonadClientUI( getsSession+                 , modifySession+                 , updateClientLeader+                 , getCacheBfs+                 , getCachePath+                 )+    -- * Assorted primitives+  , clientPrintUI, debugPossiblyPrintUI, getSession, putSession, displayFrames+  , connFrontendFrontKey, setFrontAutoYes, frontendShutdown, printScreen+  , chanFrontend, anyKeyPressed, discardPressedKey, resetPressedKeys+  , revCmdMap, getReportUI, getMiniHintAiming, computeChosenLore+  , getArenaUI, viewedLevelUI, mxhairToPos, xhairToPos, setXHairFromGUI+  , clearAimMode, getFontSetup, scoreToSlideshow, defaultHistory+  , tellAllClipPS, tellGameClipPS, elapsedSessionTimeGT+  , resetSessionStart, resetGameStart, partActorLeader, partPronounLeader+  , tryRestore, rndToActionUI, tryOpenBrowser+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , connFrontend, displayFrame+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Monad.Trans.State.Strict as St+import qualified Data.EnumMap.Strict as EM+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Data.Time.Clock+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import qualified Data.Vector.Unboxed as U+import qualified NLP.Miniutter.English as MU+import           System.IO (hFlush, stdout)+import           Web.Browser (openBrowser)++import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Content.Input+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.Frame+import qualified Game.LambdaHack.Client.UI.Frontend as Frontend+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.HighScore as HighScore+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Core.Random++-- Assumes no interleaving with other clients, because each UI client+-- in a different terminal/window/machine.+clientPrintUI :: MonadClientUI m => Text -> m ()+clientPrintUI t = liftIO $ do+  T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough+  hFlush stdout++debugPossiblyPrintUI :: MonadClientUI m => Text -> m ()+debugPossiblyPrintUI t = do+  sdbgMsgCli <- getsClient $ sdbgMsgCli . soptions+  when sdbgMsgCli $ liftIO $ do+    T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough+    hFlush stdout++-- | The monad that gives the client access to UI operations,+-- but not to modifying client state, except for the client-side pointman+-- (as opposed to pointman stores in faction data in main game state),+-- which is more of a UI concept, but is shared with AI to be able+-- to keep it when switching AI on/off and to save on typing.+class MonadClientRead m => MonadClientUI m where+  getsSession :: (SessionUI -> a) -> m a+  modifySession :: (SessionUI -> SessionUI) -> m ()+  updateClientLeader :: ActorId -> m ()+  getCacheBfs :: ActorId -> m (PointArray.Array BfsDistance)+  getCachePath :: ActorId -> Point -> m (Maybe AndPath)++getSession :: MonadClientUI m => m SessionUI+getSession = getsSession id++putSession :: MonadClientUI m => SessionUI -> m ()+putSession s = modifySession (const s)++-- | Write a UI request to the frontend and read a corresponding reply.+connFrontend :: MonadClientUI m => Frontend.FrontReq a -> m a+connFrontend req = do+  Frontend.ChanFrontend f <- getsSession schanF+  liftIO $ f req++displayFrame :: MonadClientUI m => Maybe Frame -> m ()+displayFrame mf = do+  frame <- case mf of+    Nothing -> return $! Frontend.FrontDelay 1+    Just fr -> do+      modifySession $ \cli -> cli {snframes = snframes cli + 1}+      return $! Frontend.FrontFrame fr+  connFrontend frame++-- | Push frames or delays to the frame queue. The frames depict+-- the @lid@ level.+displayFrames :: MonadClientUI m => LevelId -> PreFrames3 -> m ()+displayFrames _ [] = return ()  -- shortcut+displayFrames lid frs = do+  let framesRaw = case frs of+        [Just ((bfr, ffr), (ovProp, ovSquare, ovMono))] ->+          [Just ( (FrameBase $ U.unsafeThaw bfr, ffr)+                , (ovProp, ovSquare, ovMono) )]+        _ ->+          -- Due to the frames coming from the same base frame,+          -- we have to copy it to avoid picture corruption.+          map (fmap $ \((bfr, ffr), (ovProp, ovSquare, ovMono)) ->+                ((FrameBase $ U.thaw bfr, ffr), (ovProp, ovSquare, ovMono))) frs+  -- If display level different than the man viewed level,+  -- e.g., when our actor is attacked on a remote level,+  -- then pad with tripple delay to give more time to see the remote frames(s).+  lidV <- viewedLevelUI+  frames <- if lidV == lid+            then do+              modifySession $ \sess -> sess { sdisplayNeeded = False+                                            , sturnDisplayed = True }+              return framesRaw+            else return $ framesRaw ++ [Nothing, Nothing, Nothing]+  mapM_ displayFrame frames++-- | Write 'Frontend.FrontKey' UI request to the frontend, read the reply,+-- set pointer, return key.+connFrontendFrontKey :: MonadClientUI m => [K.KM] -> PreFrame3 -> m K.KM+connFrontendFrontKey frontKeyKeys ((bfr, ffr), (ovProp, ovSquare, ovMono)) = do+  let frontKeyFrame =+        ((FrameBase $ U.unsafeThaw bfr, ffr), (ovProp, ovSquare, ovMono))+  sautoYes <- getsSession sautoYes+  if sautoYes && (null frontKeyKeys || K.spaceKM `elem` frontKeyKeys) then do+    connFrontend $ Frontend.FrontFrame frontKeyFrame+    return K.spaceKM+  else do+    kmp <- connFrontend $ Frontend.FrontKey frontKeyKeys frontKeyFrame+    modifySession $ \sess -> sess {spointer = K.kmpPointer kmp}+    return $! K.kmpKeyMod kmp++setFrontAutoYes :: MonadClientUI m => Bool -> m ()+setFrontAutoYes b = modifySession $ \sess -> sess {sautoYes = b}++frontendShutdown :: MonadClientUI m => m ()+frontendShutdown = connFrontend Frontend.FrontShutdown++printScreen :: MonadClientUI m => m ()+printScreen = connFrontend Frontend.FrontPrintScreen++-- | Initialize the frontend chosen by the player via client options.+chanFrontend :: MonadClientUI m+             => ScreenContent -> ClientOptions -> m Frontend.ChanFrontend+chanFrontend coscreen soptions =+  liftIO $ Frontend.chanFrontendIO coscreen soptions++anyKeyPressed :: MonadClientUI m => m Bool+anyKeyPressed = connFrontend Frontend.FrontPressed++discardPressedKey :: MonadClientUI m => m ()+discardPressedKey = connFrontend Frontend.FrontDiscardKey++resetPressedKeys :: MonadClientUI m => m ()+resetPressedKeys = connFrontend Frontend.FrontResetKeys++revCmdMap :: MonadClientUI m => m (HumanCmd.HumanCmd -> K.KM)+revCmdMap = do+  CCUI{coinput=InputContent{brevMap}} <- getsSession sccui+  let revCmd cmd = case M.lookup cmd brevMap of+        Nothing -> K.undefinedKM+        Just (k : _) -> k+        Just [] -> error $ "" `showFailure` brevMap+  return revCmd++getReportUI :: MonadClientUI m => Bool -> m Report+getReportUI insideMenu = do+  saimMode <- getsSession saimMode+  sUIOptions <- getsSession sUIOptions+  report <- getsSession $ newReport . shistory+  sreqDelay <- getsSession sreqDelay+  miniHintAiming <- getMiniHintAiming+  -- Different from ordinary tutorial hints in that shown more than once.+  let detailAtDefault = (detailLevel <$> saimMode) == Just defaultDetailLevel+      detailMinimal = (detailLevel <$> saimMode) == Just minBound+      prefixColors = uMessageColors sUIOptions+      promptAim = toMsgShared prefixColors MsgPromptGeneric+                              (miniHintAiming <> "\n")+      promptDelay = toMsgShared prefixColors MsgPromptAction+                                "<press any key to regain control>"+  return $! if | not insideMenu && detailAtDefault && not detailMinimal ->+                   consReport promptAim report+               | sreqDelay == ReqDelayAlarm && not insideMenu ->+                   consReport promptDelay report+               | otherwise -> report++getMiniHintAiming :: MonadClientUI m => m Text+getMiniHintAiming = do+  saimMode <- getsSession saimMode+  (inhabitants, embeds) <-+    if isJust saimMode then computeChosenLore else return ([], [])+  sreqDelay <- getsSession sreqDelay+  mleader <- getsClient sleader+  let loreCommandAvailable = not (null inhabitants && null embeds)+                             && isJust mleader+  -- Here we assume newbies don't override default keys.+  return $! T.unwords $ concat+    [ ["Aiming mode:"]+    , ["'~' for lore," | loreCommandAvailable ]+    , ["'f' to fling," | sreqDelay /= ReqDelayHandled]+    , [if loreCommandAvailable && sreqDelay /= ReqDelayHandled+       then "SPACE or RMB to hush,"  -- shorter, because less space left+       else "SPACE or RMB to cycle detail,"]+    , ["ESC to cancel."] ]++computeChosenLore :: MonadClientUI m+                  => m ([(ActorId, Actor)], [(ItemId, ItemQuant)])+computeChosenLore = do+  side <- getsClient sside+  xhairPos <- xhairToPos+  lidV <- viewedLevelUI+  let isOurs (_, b) = bfid b == side+  inhabitants0 <- getsState $ filter (not . isOurs)+                              . posToAidAssocs xhairPos lidV+  embeds0 <- getsState $ EM.assocs . getEmbedBag lidV xhairPos+  return (inhabitants0, embeds0)++getArenaUI :: MonadClientUI m => m LevelId+getArenaUI = do+  let fallback = do+        side <- getsClient sside+        fact <- getsState $ (EM.! side) . sfactionD+        case gquit fact of+          Just Status{stDepth} -> return $! toEnum stDepth+          Nothing -> getEntryArena fact+  mleader <- getsClient sleader+  case mleader of+    Just leader -> do+      -- The leader may just be teleporting (e.g., due to displace+      -- over terrain not in FOV) so not existent momentarily.+      mem <- getsState $ EM.member leader . sactorD+      if mem+      then getsState $ blid . getActorBody leader+      else fallback+    Nothing -> fallback++viewedLevelUI :: MonadClientUI m => m LevelId+viewedLevelUI = do+  arena <- getArenaUI+  saimMode <- getsSession saimMode+  return $! maybe arena aimLevelId saimMode++mxhairToPos :: MonadClientUI m => m (Maybe Point)+mxhairToPos = do+  lidV <- viewedLevelUI+  mleader <- getsClient sleader+  sxhair <- getsSession sxhair+  getsState $ aidTgtToPos mleader lidV sxhair++xhairToPos :: MonadClientUI m => m Point+xhairToPos = do+  mxhairPos <- mxhairToPos+  mleader <- getsClient sleader+  fallback <- case mleader of+    Nothing -> return originPoint+    Just leader -> getsState $ bpos . getActorBody leader+  return $! fromMaybe fallback mxhairPos++setXHairFromGUI :: MonadClientUI m => Maybe Target -> m ()+setXHairFromGUI xhair2 = do+  xhair0 <- getsSession sxhair+  modifySession $ \sess -> sess {sxhairGoTo = Nothing}+  when (xhair0 /= xhair2) $ modifySession $ \sess -> sess {sxhair = xhair2}++-- If aim mode is exited, usually the player had the opportunity to deal+-- with xhair on a foe spotted on another level, so now move xhair+-- back to the leader level.+clearAimMode :: MonadClientUI m => m ()+clearAimMode = do+  lidVOld <- viewedLevelUI  -- not in aiming mode at this point+  xhairPos <- xhairToPos  -- computed while still in aiming mode+  modifySession $ \sess -> sess {saimMode = Nothing}+  lidV <- viewedLevelUI  -- not in aiming mode at this point+  when (lidVOld /= lidV) $ do+    sxhairOld <- getsSession sxhair+    let sxhair = case sxhairOld of+          Just TPoint{} -> Just $ TPoint TUnknown lidV xhairPos+            -- the point is possibly unknown on this level; unimportant anyway+          _ -> sxhairOld+    setXHairFromGUI sxhair++-- We can't support setup @FontSetup SquareFont MonoFont MonoFont@+-- at this time, because the mono layer needs to overwrite the prop layer+-- and so has to be distinct even if the underlying font is mono for both.+getFontSetup :: MonadClientUI m => m FontSetup+getFontSetup = do+  soptions@ClientOptions{schosenFontset, sfontsets} <- getsClient soptions+  let chosenFontsetID = fromJust schosenFontset+      chosenFontset = case lookup chosenFontsetID sfontsets of+        Nothing -> error $ "Fontset not defined in config file"+                           `showFailure` chosenFontsetID+        Just fs -> fs+      multiFont = Frontend.frontendName soptions == "sdl"+                  && not (T.null (fontPropRegular chosenFontset))+  return $! if multiFont then multiFontSetup else singleFontSetup++scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow+scoreToSlideshow total status = do+  CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+  fid <- getsClient sside+  scoreDict <- getsState shigh+  gameModeId <- getsState sgameModeId+  gameMode <- getGameMode+  time <- getsState stime+  dungeonTotal <- getsState sgold+  date <- liftIO getPOSIXTime+  tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date+  curChalSer <- getsClient scurChal+  factionD <- getsState sfactionD+  let fact = factionD EM.! fid+      table = HighScore.getTable gameModeId scoreDict+      gameModeName = mname gameMode+      theirVic (fi, fa) | isFoe fid fact fi+                          && not (isHorrorFact fa) = Just $ gvictims fa+                        | otherwise = Nothing+      theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD+      ourVic (fi, fa) | isFriend fid fact fi = Just $ gvictims fa+                      | otherwise = Nothing+      ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD+      (worthMentioning, (ntable, pos)) =+        HighScore.register table total dungeonTotal time status date curChalSer+                           (T.unwords $ tail $ T.words $ gname fact)+                           ourVictims theirVictims+                           (fhiCondPoly $ gkind fact)+  fontSetup <- getFontSetup+  let sli = highSlideshow fontSetup False rwidth (rheight - 1) ntable pos+                          gameModeName tz+  return $! if worthMentioning+            then sli+            else emptySlideshow++defaultHistory :: MonadClientUI m => m History+defaultHistory = do+  sUIOptions <- getsSession sUIOptions+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  let displayHints = fromMaybe curTutorial overrideTut+  liftIO $ do+    utcTime <- getCurrentTime+    timezone <- getTimeZone utcTime+    let curDate = T.pack $ take 19 $ show $ utcToLocalTime timezone utcTime+        emptyHist = emptyHistory $ uHistoryMax sUIOptions+        msg = toMsgShared (uMessageColors sUIOptions) MsgBookKeeping+              $ "History log started on " <> curDate <> "."+        -- Tuturial hints from initial message can be repeated.+        (_, nhistory, _) =+          addToReport S.empty displayHints False emptyHist msg timeZero+    return nhistory++tellAllClipPS :: MonadClientUI m => m ()+tellAllClipPS = do+  bench <- getsClient $ sbenchmark . soptions+  when bench $ do+    sstartPOSIX <- getsSession sstart+    curPOSIX <- liftIO getPOSIXTime+    allTime <- getsSession sallTime+    gtime <- getsState stime+    allNframes <- getsSession sallNframes+    gnframes <- getsSession snframes+    let time = absoluteTimeAdd allTime gtime+        nframes = allNframes + gnframes+        diff = fromRational $ toRational $ curPOSIX - sstartPOSIX+        cps = intToDouble (timeFit time timeClip) / diff+        fps = intToDouble nframes / diff+    clientPrintUI $+      "Session time:" <+> tshow diff <> "s; frames:" <+> tshow nframes <> "."+      <+> "Average clips per second:" <+> tshow cps <> "."+      <+> "Average FPS:" <+> tshow fps <> "."++tellGameClipPS :: MonadClientUI m => m ()+tellGameClipPS = do+  bench <- getsClient $ sbenchmark . soptions+  when bench $ do+    sgstartPOSIX <- getsSession sgstart+    curPOSIX <- liftIO getPOSIXTime+    -- If loaded game, don't report anything.+    unless (sgstartPOSIX == 0) $ do+      time <- getsState stime+      nframes <- getsSession snframes+      let diff = fromRational $ toRational $ curPOSIX - sgstartPOSIX+          cps = intToDouble (timeFit time timeClip) / diff+          fps = intToDouble nframes / diff+      -- This means: "Game portion after last reload time:...".+      clientPrintUI $+        "Game time:" <+> tshow diff <> "s; frames:" <+> tshow nframes <> "."+        <+> "Average clips per second:" <+> tshow cps <> "."+        <+> "Average FPS:" <+> tshow fps <> "."++-- TODO: for speed and resolution use+-- https://hackage.haskell.org/package/chronos+-- or the number_of_nanonseconds functionality+-- in Data.Time.Clock.System, once it arrives there+elapsedSessionTimeGT :: MonadClientRead m => POSIXTime -> Int -> m Bool+elapsedSessionTimeGT sstartPOSIX stopAfter = do+  current <- liftIO getPOSIXTime+  return $! (fromIntegralWrap :: Int -> NominalDiffTime) stopAfter+            + sstartPOSIX+            <= current++resetSessionStart :: MonadClientUI m => m ()+resetSessionStart = do+  sstart <- liftIO getPOSIXTime+  modifySession $ \sess -> sess {sstart}+  resetGameStart++resetGameStart :: MonadClientUI m => m ()+resetGameStart = do+  sgstart <- liftIO getPOSIXTime+  time <- getsState stime+  nframes <- getsSession snframes+  modifySession $ \sess ->+    sess { sgstart+        , sallTime = absoluteTimeAdd (sallTime sess) time+        , snframes = 0+        , sallNframes = sallNframes sess + nframes }++-- | The part of speech describing the actor or the "you" pronoun if he is+-- the leader of the observer's faction.+partActorLeader :: MonadClientUI m => ActorId -> m MU.Part+partActorLeader aid = do+  mleader <- getsClient sleader+  bUI <- getsSession $ getActorUI aid+  b <- getsState $ getActorBody aid+  return $! case mleader of+    Just leader | aid == leader -> "you"+    _ | bhp b <= 0+        && not (bproj b) ->  -- avoid "the fallen falling" projectiles+      MU.Phrase ["the fallen", partActor bUI]+    _ -> partActor bUI++-- | The part of speech with the actor's pronoun or "you" if a leader+-- of the client's faction.+partPronounLeader :: MonadClientUI m => ActorId -> m MU.Part+partPronounLeader aid = do+  mleader <- getsClient sleader+  bUI <- getsSession $ getActorUI aid+  return $! case mleader of+    Just leader | aid == leader -> "you"+    _ -> partPronoun bUI++-- | Try to read saved client game state from the file system.+tryRestore :: MonadClientUI m => m (Maybe (StateClient, Maybe SessionUI))+tryRestore = do+  COps{corule} <- getsState scops+  clientOptions <- getsClient soptions+  if sbenchmark clientOptions then return Nothing+  else do+    side <- getsClient sside+    prefix <- getsClient $ ssavePrefixCli . soptions+    let fileName = prefix <> Save.saveNameCli corule side+    liftIO $ Save.restoreGame corule clientOptions fileName++-- | Invoke pseudo-random computation with the generator kept in the session.+rndToActionUI :: MonadClientUI m => Rnd a -> m a+rndToActionUI r = do+  gen1 <- getsSession srandomUI+  let (a, gen2) = St.runState r gen1+  modifySession $ \sess -> sess {srandomUI = gen2}+  return a++tryOpenBrowser :: MonadClientUI m => String -> m Bool+tryOpenBrowser address = liftIO $ openBrowser address
+ engine-src/Game/LambdaHack/Client/UI/Msg.hs view
@@ -0,0 +1,622 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Game messages displayed on top of the screen for the player to read+-- and then saved to player history.+module Game.LambdaHack.Client.UI.Msg+  ( -- * Msg+    Msg, MsgShared, toMsgShared, toMsgDistinct+  , MsgClassShowAndSave(..), MsgClassShow(..), MsgClassSave(..)+  , MsgClassIgnore(..), MsgClassDistinct(..)+  , MsgClass, interruptsRunning, disturbsResting+    -- * Report+  , Report, nullVisibleReport, consReport, renderReport, anyInReport+    -- * History+  , History, newReport, emptyHistory, addToReport, addEolToNewReport+  , archiveReport, lengthHistory, renderHistory+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , UAttrString, uToAttrString, attrStringToU+  , toMsg, MsgPrototype, tripleFromProto+  , scrapsRepeats, isTutorialHint, msgColor+  , RepMsgNK, nullRepMsgNK+  , emptyReport, renderRepetition+  , scrapRepetitionSingle, scrapRepetition, renderTimeReport+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.Char as Char+import qualified Data.Set as S+import           Data.Vector.Binary ()+import qualified Data.Vector.Unboxed as U+import           GHC.Generics (Generic)++import           Game.LambdaHack.Client.UI.Overlay+import qualified Game.LambdaHack.Common.RingBuffer as RB+import           Game.LambdaHack.Common.Time+import qualified Game.LambdaHack.Definition.Color as Color++-- * UAttrString++type UAttrString = U.Vector Word32++uToAttrString :: UAttrString -> AttrString+uToAttrString v = map Color.AttrCharW32 $ U.toList v++attrStringToU :: AttrString -> UAttrString+attrStringToU l = U.fromList $ map Color.attrCharW32 l++-- * Msg++-- | The type of a single game message.+data Msg = Msg+  { msgShow  :: AttrString  -- ^ the colours and characters of the message+                            --   to be shown on the screen; not just text,+                            --   in case there was some colour not coming+                            --   from the message class+  , msgSave  :: AttrString  -- ^ the same to be saved in the message log only+  , msgClass :: MsgClass+  }+  deriving (Show, Eq, Ord, Generic)++instance Binary Msg++toMsg :: [(String, Color.Color)] -> MsgPrototype -> Msg+toMsg prefixColors msgProto =+  let (tShow, tSave, msgClass) = tripleFromProto msgProto+      msgClassName = showSimpleMsgClass msgClass+      mprefixColor = find ((`isPrefixOf` msgClassName) . fst) prefixColors+      color = maybe (msgColor msgClass) snd mprefixColor+      msgShow = textFgToAS color tShow+      msgSave = textFgToAS color tSave+  in Msg {..}++data MsgPrototype =+    MsgProtoShowAndSave MsgClassShowAndSave Text+  | MsgProtoShow MsgClassShow Text+  | MsgProtoSave MsgClassSave Text+  | MsgProtoIgnore MsgClassIgnore+  | MsgProtoDistinct MsgClassDistinct Text Text++tripleFromProto :: MsgPrototype -> (Text, Text, MsgClass)+tripleFromProto = \case+  MsgProtoShowAndSave x t -> (t, t, MsgClassShowAndSave x)+  MsgProtoShow x t -> (t, "", MsgClassShow x)+  MsgProtoSave x t -> ("", t, MsgClassSave x)+  MsgProtoIgnore x -> ("", "", MsgClassIgnore x)+  MsgProtoDistinct x t1 t2 -> (t1, t2, MsgClassDistinct x)++class MsgShared a where+  toMsgShared :: [(String, Color.Color)] -> a -> Text -> Msg++instance MsgShared MsgClassShowAndSave where+  toMsgShared prefixColors msgClass t =+    toMsg prefixColors $ MsgProtoShowAndSave msgClass t++instance MsgShared MsgClassShow where+  toMsgShared prefixColors msgClass t =+    toMsg prefixColors $ MsgProtoShow msgClass t++instance MsgShared MsgClassSave where+  toMsgShared prefixColors msgClass t =+    toMsg prefixColors $ MsgProtoSave msgClass t++instance MsgShared MsgClassIgnore where+  toMsgShared prefixColors msgClass _ =+    toMsg prefixColors $ MsgProtoIgnore msgClass++toMsgDistinct :: [(String, Color.Color)] -> MsgClassDistinct -> Text -> Text+              -> Msg+toMsgDistinct prefixColors msgClass t1 t2 =+  toMsg prefixColors $ MsgProtoDistinct msgClass t1 t2++-- Each constructor name should have length as asserted in @emptyReport@,+-- so that the message log with message classes (if set in config) looks tidy.+data MsgClass =+    MsgClassShowAndSave MsgClassShowAndSave+  | MsgClassShow MsgClassShow+  | MsgClassSave MsgClassSave+  | MsgClassIgnore MsgClassIgnore+  | MsgClassDistinct MsgClassDistinct+  deriving (Show, Eq, Ord, Generic)++instance Binary MsgClass++showSimpleMsgClass :: MsgClass -> String+showSimpleMsgClass = \case+  MsgClassShowAndSave x -> show x+  MsgClassShow x -> show x+  MsgClassSave x -> show x+  MsgClassIgnore x -> show x+  MsgClassDistinct x -> show x++data MsgClassShowAndSave =+    MsgBookKeeping+  | MsgStatusWakeup+  | MsgStatusStopUs+  | MsgStatusStopThem+  | MsgItemCreation+  | MsgItemRuination+  | MsgDeathVictory+  | MsgDeathDeafeat+  | MsgDeathBoring+  | MsgRiskOfDeath+  | MsgPointmanSwap+  | MsgFactionIntel+  | MsgFinalOutcome+  | MsgBackdropInfo+  | MsgTerrainReveal+  | MsgItemDiscovery+  | MsgSpottedActor+  | MsgItemMovement+  | MsgActionMajor+  | MsgActionMinor+  | MsgEffectMajor+  | MsgEffectMedium+  | MsgEffectMinor+  | MsgMiscellanous+  | MsgHeardOutside+  | MsgHeardNearby+  | MsgHeardFaraway+  | MsgBackdropFocus+  | MsgActionWarning+  | MsgRangedMightyWe+  | MsgRangedMightyUs+  | MsgRangedOthers  -- not ours or projectiles are hit+  | MsgRangedNormalUs+  | MsgGoodMiscEvent+  | MsgBadMiscEvent+  | MsgNeutralEvent+  | MsgSpecialEvent+  | MsgMeleeMightyWe+  | MsgMeleeMightyUs+  | MsgMeleeComplexWe+  | MsgMeleeComplexUs+  | MsgMeleeOthers  -- not ours or projectiles are hit+  | MsgMeleeNormalUs+  | MsgActionComplete+  | MsgAtFeetMajor+  | MsgAtFeetMinor+  | MsgTutorialHint+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary MsgClassShowAndSave++data MsgClassShow =+    MsgPromptGeneric+  | MsgPromptFocus+  | MsgPromptMention+  | MsgPromptModify+  | MsgPromptActors+  | MsgPromptItems+  | MsgPromptAction+  | MsgActionAlert+  | MsgSpottedThreat+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary MsgClassShow++data MsgClassSave =+    MsgInnerWorkSpam+  | MsgNumericReport+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary MsgClassSave++data MsgClassIgnore =+    MsgMacroOperation+  | MsgRunStopReason+  | MsgStopPlayback+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary MsgClassIgnore++data MsgClassDistinct =+    MsgSpottedItem+  | MsgStatusSleep+  | MsgStatusGoodUs+  | MsgStatusBadUs+  | MsgStatusOthers+  | MsgStatusBenign+  | MsgStatusWarning+  | MsgStatusLongerUs+  | MsgStatusLongThem+  deriving (Show, Eq, Ord, Enum, Bounded, Generic)++instance Binary MsgClassDistinct++interruptsRunning :: MsgClass -> Bool+interruptsRunning = \case+  MsgClassShowAndSave x -> case x of+    MsgBookKeeping -> False+    MsgStatusStopThem -> False+    MsgItemMovement -> False+    MsgActionMinor -> False+    MsgEffectMinor -> False+    MsgMiscellanous -> False  -- taunts are colourful, but spammy+    MsgHeardOutside -> False  -- cause must be 'profound', but even taunts are+    MsgHeardFaraway -> False+    -- MsgHeardNearby interrupts, even if running started while hearing close+    MsgRangedOthers -> False+    MsgNeutralEvent -> False+    MsgAtFeetMinor -> False+    _ -> True+  MsgClassShow x -> case x of+    MsgPromptGeneric -> False+    MsgPromptFocus -> False+    MsgPromptMention -> False+    MsgPromptModify -> False+    MsgPromptActors -> False+    MsgPromptItems -> False+    MsgPromptAction -> False+    MsgActionAlert -> True  -- action alerts or questions cause alarm+    MsgSpottedThreat -> True+  MsgClassSave x -> case x of+    MsgInnerWorkSpam -> False+    MsgNumericReport -> False+  MsgClassIgnore x -> case x of+    MsgMacroOperation -> False+    MsgRunStopReason -> True+    MsgStopPlayback -> True+  MsgClassDistinct x -> case x of+    MsgSpottedItem -> False+    MsgStatusLongThem -> False+    MsgStatusOthers -> False+    MsgStatusBenign -> False+    MsgStatusWarning -> False+    _ -> True++disturbsResting :: MsgClass -> Bool+disturbsResting = \case+  MsgClassShowAndSave x -> case x of+    MsgPointmanSwap -> False  -- handled separately+    MsgItemDiscovery -> False  -- medium importance+    MsgHeardNearby -> False  -- handled separately; no disturbance if old+    _ -> interruptsRunning $ MsgClassShowAndSave x+  msgClass -> interruptsRunning msgClass++scrapsRepeats :: MsgClass -> Bool+scrapsRepeats = \case+  MsgClassShowAndSave x -> case x of+    MsgBookKeeping -> False  -- too important to scrap+    MsgDeathDeafeat -> False+    MsgRiskOfDeath -> False+    MsgFinalOutcome -> False+    _ -> True+  MsgClassShow x -> case x of+    MsgPromptGeneric -> False+    MsgPromptFocus -> False+    MsgPromptMention -> False+    MsgPromptModify -> False+    MsgPromptActors -> False+    MsgPromptItems -> False+    MsgPromptAction -> False+    MsgActionAlert -> False+    MsgSpottedThreat -> True+  MsgClassSave x -> case x of+    MsgInnerWorkSpam -> True+    MsgNumericReport -> True+  MsgClassIgnore _ -> False  -- ignored, so no need to scrap+  MsgClassDistinct _x -> True++isTutorialHint :: MsgClass -> Bool+isTutorialHint = \case+  MsgClassShowAndSave x -> case x of  -- show and save: least surprise+    MsgTutorialHint -> True+    _ -> False+  MsgClassShow _ -> False+  MsgClassSave _ -> False+  MsgClassIgnore _ -> False+  MsgClassDistinct _ -> False++-- Only initially @White@ colour in text (e.g., not highlighted @BrWhite@)+-- gets replaced by the one indicated.+msgColor :: MsgClass -> Color.Color+msgColor = \case+  MsgClassShowAndSave x -> case x of+    MsgBookKeeping -> Color.cBoring+    MsgStatusWakeup -> Color.cWakeUp+    MsgStatusStopUs -> Color.cBoring+    MsgStatusStopThem -> Color.cBoring+    MsgItemCreation -> Color.cGreed+    MsgItemRuination -> Color.cBoring  -- common, colourful components created+    MsgDeathVictory -> Color.cVeryGoodEvent+    MsgDeathDeafeat -> Color.cVeryBadEvent+    MsgDeathBoring -> Color.cBoring+    MsgRiskOfDeath -> Color.cGraveRisk+    MsgPointmanSwap -> Color.cBoring+    MsgFactionIntel -> Color.cMeta  -- good or bad+    MsgFinalOutcome -> Color.cGameOver+    MsgBackdropInfo -> Color.cBoring+    MsgTerrainReveal -> Color.cIdentification+    MsgItemDiscovery -> Color.cIdentification+    MsgSpottedActor -> Color.cBoring  -- common; warning in @MsgSpottedThreat@+    MsgItemMovement -> Color.cBoring+    MsgActionMajor -> Color.cBoring+    MsgActionMinor -> Color.cBoring+    MsgEffectMajor -> Color.cRareNeutralEvent+    MsgEffectMedium -> Color.cNeutralEvent+    MsgEffectMinor -> Color.cBoring+    MsgMiscellanous -> Color.cBoring+    MsgHeardOutside -> Color.cBoring+    MsgHeardNearby -> Color.cGraveRisk+    MsgHeardFaraway -> Color.cRisk+    MsgBackdropFocus -> Color.cVista+    MsgActionWarning -> Color.cMeta+    MsgRangedMightyWe -> Color.cGoodEvent+    MsgRangedMightyUs -> Color.cVeryBadEvent+    MsgRangedOthers -> Color.cBoring+    MsgRangedNormalUs -> Color.cBadEvent+    MsgGoodMiscEvent -> Color.cGoodEvent+    MsgBadMiscEvent -> Color.cBadEvent+    MsgNeutralEvent -> Color.cNeutralEvent+    MsgSpecialEvent -> Color.cRareNeutralEvent+    MsgMeleeMightyWe -> Color.cGoodEvent+    MsgMeleeMightyUs -> Color.cVeryBadEvent+    MsgMeleeComplexWe -> Color.cGoodEvent+    MsgMeleeComplexUs -> Color.cBadEvent+    MsgMeleeOthers -> Color.cBoring+    MsgMeleeNormalUs -> Color.cBadEvent+    MsgActionComplete -> Color.cBoring+    MsgAtFeetMajor -> Color.cBoring+    MsgAtFeetMinor -> Color.cBoring+    MsgTutorialHint -> Color.cTutorialHint+  MsgClassShow x -> case x of+    MsgPromptGeneric -> Color.cBoring+    MsgPromptFocus -> Color.cVista+    MsgPromptMention -> Color.cNeutralEvent+    MsgPromptModify -> Color.cRareNeutralEvent+    MsgPromptActors -> Color.cRisk+    MsgPromptItems -> Color.cGreed+    MsgPromptAction -> Color.cMeta+    MsgActionAlert -> Color.cMeta+    MsgSpottedThreat -> Color.cGraveRisk+  MsgClassSave x -> case x of+    MsgInnerWorkSpam -> Color.cBoring+    MsgNumericReport -> Color.cBoring+  MsgClassIgnore x -> case x of+    MsgMacroOperation -> Color.cBoring+    MsgRunStopReason -> Color.cBoring+    MsgStopPlayback -> Color.cMeta+  MsgClassDistinct x -> case x of+    MsgSpottedItem -> Color.cBoring+    MsgStatusSleep -> Color.cSleep+    MsgStatusGoodUs -> Color.cGoodEvent+    MsgStatusBadUs -> Color.cBadEvent+    MsgStatusOthers -> Color.cBoring+    MsgStatusBenign -> Color.cBoring+    MsgStatusWarning -> Color.cMeta+    MsgStatusLongerUs -> Color.cBoring  -- not important enough+    MsgStatusLongThem -> Color.cBoring  -- not important enough, no disturb even++-- * Report++data RepMsgNK = RepMsgNK {repMsg :: Msg, _repShow :: Int, _repSave :: Int}+  deriving (Show, Generic)++instance Binary RepMsgNK++-- | If only one of the message components is non-empty and non-whitespace,+-- but its count is zero, the message is considered empty.+nullRepMsgNK :: RepMsgNK -> Bool+nullRepMsgNK (RepMsgNK Msg{..} _ _) =+  all (Char.isSpace . Color.charFromW32) msgShow+  && all (Char.isSpace . Color.charFromW32) msgSave++-- | The set of messages, with repetitions, to show at the screen at once.+newtype Report = Report [RepMsgNK]+  deriving (Show, Binary)++-- | Empty set of messages.+emptyReport :: Report+emptyReport = assert (let checkLen msgClass =+                            let len = length (showSimpleMsgClass msgClass)+                            in len >= 14 && len <= 17+                          l = map MsgClassShowAndSave [minBound .. maxBound]+                              ++ map MsgClassShow [minBound .. maxBound]+                              ++ map MsgClassSave [minBound .. maxBound]+                              ++ map MsgClassIgnore [minBound .. maxBound]+                              ++ map MsgClassDistinct [minBound .. maxBound]+                      in allB checkLen l)+              $ Report []  -- as good place as any to verify display lengths++-- | Test if the list of non-whitespace messages is empty.+nullVisibleReport :: Report -> Bool+nullVisibleReport (Report l) =+  all (all (Char.isSpace . Color.charFromW32) . msgShow . repMsg) l++-- | Add a message to the start of report.+consReport :: Msg -> Report -> Report+consReport msg (Report r) = Report $ r ++ [RepMsgNK msg 1 1]++-- | Render a report as a (possibly very long) list of 'AttrString'.+renderReport :: Bool -> Report -> [AttrString]+renderReport displaying (Report r) =+  let rep = map (\(RepMsgNK msg n k) -> if displaying+                                        then (msgShow msg, n)+                                        else (msgSave msg, k)) r+  in reverse $ map renderRepetition rep++renderRepetition :: (AttrString, Int) -> AttrString+renderRepetition (asRaw, n) =+  let as = dropWhileEnd (Char.isSpace . Color.charFromW32) asRaw+  in if n <= 1 || null as+     then as+     else as ++ stringToAS ("<x" ++ show n ++ ">")++anyInReport :: (MsgClass -> Bool) -> Report -> Bool+anyInReport f (Report xns) = any (f . msgClass . repMsg) xns++-- * History++-- | The history of reports. This is a ring buffer of the given length+-- containing old archived history and two most recent reports stored+-- separately.+data History = History+  { newReport       :: Report+  , newTime         :: Time+  , oldReport       :: Report+  , oldTime         :: Time+  , archivedHistory :: RB.RingBuffer UAttrString }+  deriving (Show, Generic)++instance Binary History++-- | Empty history of the given maximal length.+emptyHistory :: Int -> History+emptyHistory size =+  let ringBufferSize = size - 1  -- a report resides outside the buffer+  in History emptyReport timeZero emptyReport timeZero+             (RB.empty ringBufferSize U.empty)++scrapRepetitionSingle :: (AttrString, Int)+                      -> [(AttrString, Int)]+                      -> [(AttrString, Int)]+                      -> (Bool, [(AttrString, Int)], [(AttrString, Int)])+scrapRepetitionSingle (s1, n1) rest1 oldMsgs =+  let butLastEOLs = dropWhileEnd ((== '\n') . Color.charFromW32)+      eqs1 (s2, _) = butLastEOLs s1 == butLastEOLs s2+  in case break eqs1 rest1 of+    (_, []) -> case break eqs1 oldMsgs of+      (noDup, (_, n2) : rest2) ->+        -- We keep the occurence of the message in the new report only.+        let newReport = (s1, n1 + n2) : rest1+            oldReport = noDup ++ ([], 0) : rest2+        in (True, newReport, oldReport)+      _ -> (False, (s1, n1) : rest1, oldMsgs)+    (noDup, (s2, n2) : rest3) ->+      -- We keep the older (and so, oldest) occurence of the message,+      -- to avoid visual disruption by moving the message around.+      let newReport = ([], 0) : noDup ++ (s2, n1 + n2) : rest3+          oldReport = oldMsgs+      in (True, newReport, oldReport)++scrapRepetition :: History -> Maybe History+scrapRepetition History{ newReport = Report newMsgs+                       , oldReport = Report oldMsgs+                       , .. } =+  case newMsgs of+    -- We take into account only first message of the new report,+    -- because others were deduplicated as they were added.+    -- We keep the message in the new report, because it should not+    -- vanish from the screen. In this way the message may be passed+    -- along many reports.+    RepMsgNK msg1 n1 k1 : rest1 ->+      let -- We ignore message classes and scrap even if same strings+          -- come from different classes. Otherwise user would be confused.+          makeShow = map (\(RepMsgNK msg n _) -> (msgShow msg, n))+          makeSave = map (\(RepMsgNK msg _ k) -> (msgSave msg, k))+          (scrapShowNeeded, scrapShowNew, scrapShowOld) =+            scrapRepetitionSingle (msgShow msg1, n1)+                                  (makeShow rest1)+                                  (makeShow oldMsgs)+          (scrapSaveNeeded, scrapSaveNew, scrapSaveOld) =+            scrapRepetitionSingle (msgSave msg1, k1)+                                  (makeSave rest1)+                                  (makeSave oldMsgs)+      in if scrapShowNeeded || scrapSaveNeeded+         then let combineMsg _ ([], _) ([], _) = Nothing+                  combineMsg msg (s, n) (t, k) = Just $+                    RepMsgNK msg{msgShow = s, msgSave = t} n k+                  zipMsg l1 l2 l3 = Report $ catMaybes $+                    zipWith3 combineMsg (map repMsg l1) l2 l3+                  newReport = zipMsg newMsgs scrapShowNew scrapSaveNew+                  oldReport = zipMsg oldMsgs scrapShowOld scrapSaveOld+              in Just History{..}+         else Nothing+    _ -> error "scrapRepetition: empty new report for scrapping"++-- | Add a message to the new report of history, eliminating a possible+-- duplicate and noting its existence in the result.+addToReport :: S.Set Msg -> Bool -> Bool -> History -> Msg -> Time+            -> (S.Set Msg, History, Bool)+addToReport usedHints displayHints inMelee+            oldHistory@History{newReport = Report r, ..} msgRaw time =+  -- When each turn we lose HP, stuff that wouldn't interrupt+  -- running should go at most to message log, not onto the screen,+  -- unless it goes only onto screen, so the message would be lost.+  let isMsgClassShow = \case+        MsgClassShow{} -> True+        _ -> False+      msg = if inMelee+               && not (interruptsRunning (msgClass msgRaw))+               && not (isMsgClassShow $ msgClass msgRaw)+            then msgRaw {msgShow = []}+            else msgRaw+      repMsgNK = RepMsgNK msg 1 1+      newH = History { newReport = Report $ repMsgNK : r+                     , newTime = time+                     , .. }+      msgIsHint = isTutorialHint (msgClass msg)+      msgUsedAsHint = S.member msg usedHints+      newUsedHints = if msgIsHint && displayHints && not msgUsedAsHint+                     then S.insert msg usedHints+                     else usedHints+  in -- Tutorial hint shown only when tutorial enabled and hint not yet shown.+     if | msgIsHint && (not displayHints || msgUsedAsHint) ->+          (usedHints, oldHistory, False)+        | not (scrapsRepeats $ msgClass msg)+          || nullRepMsgNK repMsgNK ->+          -- Don't waste time on never shown messages.+          (newUsedHints, newH, False)+        | otherwise -> case scrapRepetition newH of+            Just scrappedH -> (newUsedHints, scrappedH, True)+            Nothing -> (newUsedHints, newH, False)++-- | Add a newline to end of the new report of history, unless empty.+addEolToNewReport :: History -> History+addEolToNewReport hist =+  let addEolToReport (Report []) = Report []+      addEolToReport (Report (hd : tl)) = Report $ addEolToRepMsgNK hd : tl+      addEolToRepMsgNK rm = rm {repMsg = addEolToMsg $ repMsg rm}+      addEolToMsg msg = msg { msgShow = addEolToAS $ msgShow msg+                            , msgSave = addEolToAS $ msgSave msg }+      addEolToAS as = as ++ stringToAS "\n"+  in hist {newReport = addEolToReport $ newReport hist}++-- | Archive old report to history, filtering out messages with 0 duplicates+-- and prompts. Set up new report with a new timestamp.+archiveReport :: History -> History+archiveReport History{newReport=Report newMsgs, ..} =+  let newFiltered@(Report r) = Report $ filter (not . nullRepMsgNK) newMsgs+  in if null r+     then -- Drop empty new report.+          History emptyReport timeZero oldReport oldTime archivedHistory+     else let lU = map attrStringToU+                   $ renderTimeReport oldTime oldReport+          in History emptyReport timeZero newFiltered newTime+             $ foldl' (\ !h !v -> RB.cons v h) archivedHistory lU++renderTimeReport :: Time -> Report -> [AttrString]+renderTimeReport t rep@(Report r) =+  let turns = t `timeFitUp` timeTurn+      repMsgs = renderReport False rep+      mgsClasses = reverse $ map (showSimpleMsgClass . msgClass . repMsg) r+      turnsString = show turns+      isSpace32 = Char.isSpace . Color.charFromW32+      worthSaving = not . all isSpace32+      renderClass (as, msgClassString) =+        let lenUnderscore = 17 - length msgClassString+                            + max 0 (3 - length turnsString)+        in stringToAS (turnsString ++ ":")+           ++ map (Color.attrChar2ToW32 Color.BrBlack)+                  ("[" ++ replicate lenUnderscore '_' ++ msgClassString ++ "]")+           ++ [Color.spaceAttrW32]+           ++ dropWhile isSpace32 as+  in map renderClass $ filter (worthSaving . fst) $ zip repMsgs mgsClasses++lengthHistory :: History -> Int+lengthHistory History{oldReport, archivedHistory} =+  RB.length archivedHistory+  + length (renderTimeReport timeZero oldReport)+      -- matches @renderHistory@++-- | Render history as many lines of text. New report is not rendered.+-- It's expected to be empty when history is shown.+renderHistory :: History -> [AttrString]+renderHistory History{..} =+  map uToAttrString (RB.toList archivedHistory)+  ++ renderTimeReport oldTime oldReport
+ engine-src/Game/LambdaHack/Client/UI/MsgM.hs view
@@ -0,0 +1,151 @@+-- | Monadic operations on game messages.+module Game.LambdaHack.Client.UI.MsgM+  ( msgAddDuplicate, msgAddDistinct, msgAdd, msgLnAdd+  , promptMainKeys, recordHistory, tutorialHintMsgAdd+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.TutorialHints+  (TutorialHints, renderTutorialHints)+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Definition.Defs++sniffMessages :: Bool+sniffMessages = False++-- | Add a shared message to the current report. Say if it was a duplicate.+msgAddDuplicate :: (MonadClientUI m, MsgShared a) => a -> Text -> m Bool+msgAddDuplicate msgClass t = do+  sUIOptions <- getsSession sUIOptions+  time <- getsState stime+  history <- getsSession shistory+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  usedHints <- getsSession susedHints+  lid <- getArenaUI+  condInMelee <- condInMeleeM lid+  smuteMessages <- getsSession smuteMessages+  let displayHints = fromMaybe curTutorial overrideTut+      msg = toMsgShared (uMessageColors sUIOptions) msgClass t+      (nusedHints, nhistory, duplicate) =+        addToReport usedHints displayHints condInMelee history msg time+  unless smuteMessages $ do+    modifySession $ \sess -> sess {shistory = nhistory, susedHints = nusedHints}+    when sniffMessages $ clientPrintUI t+  return duplicate++-- | Add a message comprising of two different texts, one to show, the other+-- to save to messages log, to the current report.+msgAddDistinct :: MonadClientUI m => MsgClassDistinct -> (Text, Text) -> m ()+msgAddDistinct msgClass (t1, t2) = do+  sUIOptions <- getsSession sUIOptions+  time <- getsState stime+  history <- getsSession shistory+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  usedHints <- getsSession susedHints+  lid <- getArenaUI+  condInMelee <- condInMeleeM lid+  smuteMessages <- getsSession smuteMessages+  let displayHints = fromMaybe curTutorial overrideTut+      msg = toMsgDistinct (uMessageColors sUIOptions) msgClass t1 t2+      (nusedHints, nhistory, _) =+        addToReport usedHints displayHints condInMelee history msg time+  unless smuteMessages $ do+    modifySession $ \sess -> sess {shistory = nhistory, susedHints = nusedHints}+    when sniffMessages $ clientPrintUI t1++-- | Add a message to the current report.+msgAdd :: (MonadClientUI m, MsgShared a) => a -> Text -> m ()+msgAdd msgClass t = void $ msgAddDuplicate msgClass t++-- | Add a tutorial hint message to the current report.+tutorialHintMsgAdd :: MonadClientUI m => TutorialHints -> m ()+tutorialHintMsgAdd = msgAdd MsgTutorialHint . renderTutorialHints++-- | Add a message to the current report. End previously collected report,+-- if any, with newline.+msgLnAdd :: (MonadClientUI m, MsgShared a) => a -> Text -> m ()+msgLnAdd msgClass t = do+  smuteMessages <- getsSession smuteMessages+  unless smuteMessages $+    modifySession $ \sess -> sess {shistory = addEolToNewReport $ shistory sess}+  msgAdd msgClass t++-- | Add a prompt with basic keys description.+promptMainKeys :: MonadClientUI m => m ()+promptMainKeys = do+  side <- getsClient sside+  ours <- getsState $ fidActorNotProjGlobalAssocs side+  revCmd <- revCmdMap+  let kmHelp = revCmd HumanCmd.Hint+      kmViewStash = revCmd (HumanCmd.ChooseItemMenu (MStore CStash))+      kmItemStash = revCmd (HumanCmd.MoveItem [CGround, CEqp] CStash+                                              Nothing False)+      kmXhairPointerFloor = revCmd HumanCmd.XhairPointerFloor+  saimMode <- getsSession saimMode+  UIOptions{uVi, uLeftHand} <- getsSession sUIOptions+  xhair <- getsSession sxhair+  miniHintAiming <- getMiniHintAiming+  -- The silly "axwdqezc" name of keys is chosen to match "hjklyubn",+  -- which the usual way of writing them.+  let moveKeys | uVi && uLeftHand = "keypad or axwdqezc or hjklyubn"+               | uLeftHand = "keypad or axwdqezc"+               | uVi = "keypad or hjklyubn"+               | otherwise = "keypad"+      manyTeammates = length ours > 1+      -- @Tab@ here is not a button, which we would write consistently+      -- as @TAB@, just as in our internal in-game key naming, but a key name+      -- as written on the keyboard, hence most useful to a newbie.+      keepTab = if manyTeammates+                then "Switch to another teammate with Tab, while all others auto-melee foes, if adjacent, but normally don't chase them."+                else ""+      describePos = if describeIsNormal+                    then "Describe map position with MMB or RMB."+                    else ""+      viewEquip = if stashKeysAreNormal+                  then "View shared 'I'nventory stash and stash items into the 'i'nventory."+                  else ""+      moreHelp = "Press '" <> tshow kmHelp <> "' for more help."+      describeIsNormal = kmXhairPointerFloor == K.middleButtonReleaseKM+      stashKeysAreNormal = kmViewStash == K.mkChar 'I'+                           && kmItemStash == K.mkChar 'i'+      keys | isNothing saimMode =+        "Explore with" <+> moveKeys <+> "or mouse."+        <+> describePos+        <+> viewEquip+        <+> keepTab+        <+> moreHelp+           | otherwise =+        miniHintAiming+        <+> tgtKindVerb xhair+        <+> "with" <+> moveKeys <+> "keys or mouse."+        <+> keepTab+        <+> moreHelp+  void $ msgAdd MsgPromptGeneric keys++tgtKindVerb :: Maybe Target -> Text+tgtKindVerb mtgt = case mtgt of+  Just TEnemy{} -> "Aim at enemy"+  Just TNonEnemy{} -> "Aim at non-enemy"+  Just TPoint{} -> "Aim at position"+  Just TVector{} -> "Indicate a move vector"+  Nothing -> "Start aiming"++-- | Store new report in the history and archive old report.+recordHistory :: MonadClientUI m => m ()+recordHistory =+  modifySession $ \sess -> sess {shistory = archiveReport $ shistory sess}
+ engine-src/Game/LambdaHack/Client/UI/Overlay.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE RankNTypes, TupleSections #-}+-- | Screen overlays.+module Game.LambdaHack.Client.UI.Overlay+  ( -- * DisplayFont+    DisplayFont, isPropFont, isSquareFont, isMonoFont, textSize+  , -- * FontSetup+    FontSetup(..), multiFontSetup, singleFontSetup+  , -- * AttrString+    AttrString, blankAttrString, textToAS, textFgToAS, stringToAS+  , attrStringToString+  , (<+:>), (<\:>)+    -- * AttrLine+  , AttrLine, attrLine, emptyAttrLine, attrStringToAL, firstParagraph+  , textToAL, textFgToAL, stringToAL, linesAttr+  , splitAttrString, indentSplitAttrString+    -- * Overlay+  , Overlay, xytranslateOverlay, xtranslateOverlay, ytranslateOverlay+  , offsetOverlay, offsetOverlayX, typesetXY+  , updateLine, rectangleOfSpaces, maxYofOverlay, labDescOverlay+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , nonbreakableRev, isPrefixOfNonbreakable, breakAtSpace, splitAttrPhrase+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Char (isSpace)+import qualified Data.Text as T++import           Game.LambdaHack.Client.UI.PointUI+import qualified Game.LambdaHack.Definition.Color as Color++-- * DisplayFont++-- | Three types of fonts used in the UI. Overlays (layers, more or less)+-- in proportional font are overwritten by layers in square font,+-- which are overwritten by layers in mono font.+-- All overlays overwrite the rendering of the game map, which is+-- the underlying basic UI frame, comprised of square font glyps.+--+-- This type needs to be kept abstract to ensure that frontend-enforced+-- or user config-enforced font assignments in 'FontSetup'+-- (e.g., stating that the supposedly proportional font is overriden+-- to be the square font) can't be ignored. Otherwise a programmer+-- could use arbirary @DisplayFont@, instead of the one taken from 'FontSetup',+-- and so, e.g., calculating the width of an overlay so constructed+-- in order to decide where another overlay can start would be inconsistent+-- what what font is really eventually used when rendering.+--+-- Note that the order of constructors has limited effect,+-- but it illustrates how overwriting is explicitly implemented+-- in frontends that support all fonts.+data DisplayFont = PropFont | SquareFont | MonoFont+  deriving (Show, Eq, Enum)++isPropFont, isSquareFont, isMonoFont :: DisplayFont -> Bool+isPropFont = (== PropFont)+isSquareFont = (== SquareFont)+isMonoFont = (== MonoFont)++textSize :: DisplayFont -> [a] -> Int+textSize SquareFont l = 2 * length l+textSize MonoFont l = length l+textSize PropFont _ = error "size of proportional font texts is not defined"++-- * FontSetup++data FontSetup = FontSetup+  { squareFont :: DisplayFont+  , monoFont   :: DisplayFont+  , propFont   :: DisplayFont+  }+  deriving (Eq, Show)  -- for unit tests++multiFontSetup :: FontSetup+multiFontSetup = FontSetup SquareFont MonoFont PropFont++singleFontSetup :: FontSetup+singleFontSetup = FontSetup SquareFont SquareFont SquareFont++-- * AttrString++-- | String of colourful text. End of line characters permitted.+type AttrString = [Color.AttrCharW32]++blankAttrString :: Int -> AttrString+blankAttrString w = replicate w Color.spaceAttrW32++textToAS :: Text -> AttrString+textToAS !t =+  let f c l = let !ac = Color.attrChar1ToW32 c+              in ac : l+  in T.foldr f [] t++textFgToAS :: Color.Color -> Text -> AttrString+textFgToAS !fg !t =+  let f ' ' l = Color.spaceAttrW32 : l+                  -- for speed and simplicity (testing if char is a space)+                  -- we always keep the space @White@+      f c l = let !ac = Color.attrChar2ToW32 fg c+              in ac : l+  in T.foldr f [] t++stringToAS :: String -> AttrString+stringToAS = map Color.attrChar1ToW32++-- | Transform 'AttrString' type to 'String'.+attrStringToString :: AttrString -> String+attrStringToString = map Color.charFromW32++-- Follows minimorph.<+>.+infixr 6 <+:>  -- matches Monoid.<>+(<+:>) :: AttrString -> AttrString -> AttrString+(<+:>) [] l2 = l2+(<+:>) l1 [] = l1+(<+:>) l1 l2@(c2 : _) =+  if isSpace (Color.charFromW32 c2) || isSpace (Color.charFromW32 (last l1))+  then l1 ++ l2+  else l1 ++ [Color.spaceAttrW32] ++ l2++infixr 6 <\:>  -- matches Monoid.<>+(<\:>) :: AttrString -> AttrString -> AttrString+(<\:>) [] l2 = l2+(<\:>) l1 [] = l1+(<\:>) l1 l2@(c2 : _) =+  if Color.charFromW32 c2 == '\n' || Color.charFromW32 (last l1) == '\n'+  then l1 ++ l2+  else l1 ++ stringToAS "\n" ++ l2++-- We consider only these, because they are short and form a closed category.+nonbreakableRev :: [String]+nonbreakableRev = ["eht", "a", "na", "ehT", "A", "nA", "I"]++isPrefixOfNonbreakable :: AttrString -> Bool+isPrefixOfNonbreakable s =+  let isPrefixOfNb sRev nbRev = case stripPrefix nbRev sRev of+        Nothing -> False+        Just [] -> True+        Just (c : _) -> isSpace c+  in any (isPrefixOfNb $ attrStringToString s) nonbreakableRev++breakAtSpace :: AttrString -> (AttrString, AttrString)+breakAtSpace lRev =+  let (pre, post) = break (== Color.spaceAttrW32) lRev+  in case post of+    c : rest | c == Color.spaceAttrW32 ->+      if isPrefixOfNonbreakable rest+      then let (pre2, post2) = breakAtSpace rest+           in (pre ++ c : pre2, post2)+      else (pre, post)+    _ -> (pre, post)  -- no space found, give up++-- * AttrLine++-- | Line of colourful text. End of line characters forbidden. Trailing+-- @White@ space forbidden.+newtype AttrLine = AttrLine {attrLine :: AttrString}+  deriving (Show, Eq)++emptyAttrLine :: AttrLine+emptyAttrLine = AttrLine []++attrStringToAL :: AttrString -> AttrLine+attrStringToAL s =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  assert (allB (\ac -> Color.charFromW32 ac /= '\n') s) $  -- expensive in menus+  assert (null s || last s /= Color.spaceAttrW32+          `blame` attrStringToString s) $+    -- only expensive for menus, but often violated by code changes, so disabled+    -- outside test runs+#endif+    AttrLine s++firstParagraph :: AttrString -> AttrLine+firstParagraph s = case linesAttr s of+  [] -> emptyAttrLine+  l : _ -> l++textToAL :: Text -> AttrLine+textToAL !t =+  let f '\n' _ = error $ "illegal end of line in: " ++ T.unpack t+      f c l = let !ac = Color.attrChar1ToW32 c+              in ac : l+      s = T.foldr f [] t+  in AttrLine $+#ifdef WITH_EXPENSIVE_ASSERTIONS+  assert (null s || last s /= Color.spaceAttrW32 `blame` t)+#endif+    s++textFgToAL :: Color.Color -> Text -> AttrLine+textFgToAL !fg !t =+  let f '\n' _ = error $ "illegal end of line in: " ++ T.unpack t+      f ' ' l = Color.spaceAttrW32 : l+                  -- for speed and simplicity (testing if char is a space)+                  -- we always keep the space @White@+      f c l = let !ac = Color.attrChar2ToW32 fg c+              in ac : l+      s = T.foldr f [] t+  in AttrLine $+#ifdef WITH_EXPENSIVE_ASSERTIONS+  assert (null s || last s /= Color.spaceAttrW32 `blame` t)+#endif+    s++stringToAL :: String -> AttrLine+stringToAL s = attrStringToAL $ map Color.attrChar1ToW32 s++-- Mimics @lines@.+linesAttr :: AttrString -> [AttrLine]+linesAttr [] = []+linesAttr l = cons (case break (\ac -> Color.charFromW32 ac == '\n') l of+  (h, t) -> (attrStringToAL h, case t of+                                 [] -> []+                                 _ : tt -> linesAttr tt))+ where+  cons ~(h, t) = h : t++-- | Split a string into lines. Avoid breaking the line at a character+-- other than space. Remove the spaces on which lines are broken,+-- keep other spaces. In expensive assertions mode (dev debug mode)+-- fail at trailing spaces, but keep leading spaces, e.g., to make+-- distance from a text in another font. Newlines are respected.+--+-- Note that we only split wrt @White@ space, nothing else,+-- and the width, in the first argument, is calculated in characters,+-- not in UI (mono font) coordinates, so that taking and dropping characters+-- is performed correctly.+splitAttrString :: Int -> Int -> AttrString -> [AttrLine]+splitAttrString w0 w1 l = case linesAttr l of+  [] -> []+  x : xs -> splitAttrPhrase w0 w1 x ++ concatMap (splitAttrPhrase w1 w1) xs++indentSplitAttrString :: DisplayFont -> Int -> AttrString -> [AttrLine]+indentSplitAttrString font w l = assert (w > 4) $+  -- Sadly this depends on how wide the space is in propotional font,+  -- which varies wildly, so we err on the side of larger indent.+  let nspaces = case font of+        SquareFont -> 1+        MonoFont -> 2+        PropFont -> 4+      ts = splitAttrString w (w - nspaces) l+      -- Proportional spaces are very narrow.+      spaces = replicate nspaces Color.spaceAttrW32+  in case ts of+    [] -> []+    hd : tl -> hd : map (AttrLine . (spaces ++) . attrLine) tl++-- We pass empty line along for the case of appended buttons, which need+-- either space or new lines before them.+splitAttrPhrase :: Int -> Int -> AttrLine -> [AttrLine]+splitAttrPhrase w0 w1 (AttrLine xs)+  | w0 >= length xs = [AttrLine xs]  -- no problem, everything fits+  | otherwise =+      let (pre, postRaw) = splitAt w0 xs+          preRev = reverse pre+          ((ppre, ppost), post) = case postRaw of+            c : rest | c == Color.spaceAttrW32+                       && not (isPrefixOfNonbreakable preRev) ->+              (([], preRev), rest)+            _ -> (breakAtSpace preRev, postRaw)+      in if all (== Color.spaceAttrW32) ppost+         then AttrLine (reverse $ dropWhile (== Color.spaceAttrW32) preRev)+              : splitAttrPhrase w1 w1 (AttrLine post)+         else AttrLine (reverse $ dropWhile (== Color.spaceAttrW32) ppost)+              : splitAttrPhrase w1 w1 (AttrLine $ reverse ppre ++ post)++-- * Overlay++-- | A series of screen lines with start positions at which they should+-- be overlayed over the base frame or a blank screen, depending on context.+-- The position point is represented as in integer that is an index into the+-- frame character array.+-- The lines either fit the width of the screen or are intended+-- for truncation when displayed. The start positions of lines may fall outside+-- the length of the screen, too, unlike in @SingleFrame@. Then they are+-- simply not shown.+type Overlay = [(PointUI, AttrLine)]++xytranslateOverlay :: Int -> Int -> Overlay -> Overlay+xytranslateOverlay dx dy =+  map (\(PointUI x y, al) -> (PointUI (x + dx) (y + dy), al))++xtranslateOverlay :: Int -> Overlay -> Overlay+xtranslateOverlay dx = xytranslateOverlay dx 0++ytranslateOverlay :: Int -> Overlay -> Overlay+ytranslateOverlay = xytranslateOverlay 0++offsetOverlay :: [AttrLine] -> Overlay+offsetOverlay = zipWith (curry (first $ PointUI 0)) [0..]++offsetOverlayX :: [(Int, AttrLine)] -> Overlay+offsetOverlayX = zipWith (\y (x, al) -> (PointUI x y, al)) [0..]++typesetXY :: (Int, Int) -> [AttrLine] -> Overlay+typesetXY (xoffset, yoffset) =+  zipWith (\y al -> (PointUI xoffset (y + yoffset), al)) [0..]++-- @f@ should not enlarge the line beyond screen width nor introduce linebreaks.+updateLine :: Int -> (Int -> AttrString -> AttrString) -> Overlay -> Overlay+updateLine y f ov =+  let upd (p@(PointUI px py), AttrLine l) =+        if py == y then (p, AttrLine $ f px l) else (p, AttrLine l)+  in map upd ov++rectangleOfSpaces :: Int -> Int -> Overlay+rectangleOfSpaces x y =+  let blankAttrLine = AttrLine $ replicate x Color.nbspAttrW32+  in offsetOverlay $ replicate y blankAttrLine++maxYofOverlay :: Overlay -> Int+maxYofOverlay ov = let yOfOverlay (PointUI _ y, _) = y+                   in maximum $ 0 : map yOfOverlay ov++labDescOverlay :: DisplayFont -> Int -> AttrString -> (Overlay, Overlay)+labDescOverlay labFont width as =+  let (tLab, tDesc) = span (/= Color.spaceAttrW32) as+      labLen = textSize labFont tLab+      len = max 0 $ width - length tLab  -- not labLen; TODO: type more strictly+      ovLab = offsetOverlay [attrStringToAL tLab]+      ovDesc = offsetOverlayX $+        case splitAttrString len width tDesc of+          [] -> []+          l : ls -> (labLen, l) : map (0,) ls+  in (ovLab, ovDesc)
+ engine-src/Game/LambdaHack/Client/UI/PointUI.hs view
@@ -0,0 +1,54 @@+-- | UI screen coordinates.+module Game.LambdaHack.Client.UI.PointUI+  ( PointUI(..), PointSquare(..), squareToUI, uiToSquare+  , squareToMap, mapToSquare+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , mapStartY+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Game.LambdaHack.Common.Point++-- | UI screen coordinates, independent of whether square or monospace fonts+-- are being placed on the screen (though square fonts are never placed+-- on odd coordinates). These are not game map coordinates,+-- becuse UI is larger and more fine-grained than just the game map.+data PointUI = PointUI Int Int+  deriving (Show, Eq)++-- | Coordinates of the big square fonts. These are not game map coordinates,+-- because the latter are offset by @mapStartY@ and represented by @Point@.+--+-- However, confusingly, @Point@ is also used for square font glyph coordinates,+-- though exclusively in context of rendered frames to be sent to a frontend,+-- namely @PointArray.Array@, which is indexed by @Point@ and is a vector,+-- and so traditionally indexed starting from zero and not from minus one,+-- as would be needed for consistency.+data PointSquare = PointSquare Int Int+  deriving (Show, Eq)++squareToUI :: PointSquare -> PointUI+{-# INLINE squareToUI #-}+squareToUI (PointSquare x y) = PointUI (x * 2) y++uiToSquare :: PointUI -> PointSquare+{-# INLINE uiToSquare #-}+uiToSquare (PointUI x y) = PointSquare (x `div` 2) y++-- | The row where the dungeon map starts, both in @PointUI@+-- and @PointSquare@ coordinates.+mapStartY :: Int+mapStartY = 1++squareToMap :: PointSquare -> Point+{-# INLINE squareToMap #-}+squareToMap (PointSquare x y) = Point x (y - mapStartY)++mapToSquare :: Point -> PointSquare+{-# INLINE mapToSquare #-}+mapToSquare (Point x y) = PointSquare x (y + mapStartY)
+ engine-src/Game/LambdaHack/Client/UI/RunM.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE RankNTypes #-}+-- | Running and disturbance.+--+-- The general rule is: whatever is behind you (and so ignored previously),+-- determines what you ignore moving forward. This is calcaulated+-- separately for the tiles to the left, to the right and in the middle+-- along the running direction. So, if you want to ignore something+-- start running when you stand on it (or to the right or left, respectively)+-- or by entering it (or passing to the right or left, respectively).+--+-- Some things are never ignored, such as: enemies seen, imporant messages+-- heard, solid tiles and actors in the way.+module Game.LambdaHack.Client.UI.RunM+  ( continueRun+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , continueRunDir, walkableDir, tryTurning, checkAndRun+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import           GHC.Exts (inline)++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.TileKind (TileKind)+import           Game.LambdaHack.Definition.Defs++-- | Continue running in the given direction.+continueRun :: MonadClientUI m+            => LevelId -> RunParams+            -> m (Either Text RequestTimed)+continueRun arena paramOld = case paramOld of+  RunParams{ runMembers = []+           , runStopMsg = Just stopMsg } -> return $ Left stopMsg+  RunParams{ runMembers = []+           , runStopMsg = Nothing } ->+    return $ Left "selected actors no longer there"+  RunParams{ runLeader+           , runMembers = r : rs+           , runInitial+           , runStopMsg } -> do+    -- If runInitial and r == runLeader, it means the leader moves+    -- again, after all other members, in step 0,+    -- so we call continueRunDir with True to change direction once+    -- and then unset runInitial.+    let runInitialNew = runInitial && r /= runLeader+        paramIni = paramOld {runInitial = runInitialNew}+    onLevel <- getsState $ memActor r arena+    onLevelLeader <- getsState $ memActor runLeader arena+    if | not onLevel -> do+         let paramNew = paramIni {runMembers = rs }+         continueRun arena paramNew+       | not onLevelLeader -> do+         let paramNew = paramIni {runLeader = r}+         continueRun arena paramNew+       | otherwise -> do+         mdirOrRunStopMsgCurrent <- continueRunDir paramOld+         let runStopMsgCurrent =+               either Just (const Nothing) mdirOrRunStopMsgCurrent+             runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent+             -- We check @runStopMsgNew@, because even if the current actor+             -- runs OK, we want to stop soon if some others had to stop.+             runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]+             paramNew = paramIni { runMembers = runMembersNew+                                 , runStopMsg = runStopMsgNew }+         case mdirOrRunStopMsgCurrent of+           Left _ -> continueRun arena paramNew+                       -- run all others undisturbed; one time+           Right dir -> do+             updateClientLeader r+             modifySession $ \sess -> sess {srunning = Just paramNew}+             return $ Right $ ReqMove dir+         -- The potential invisible actor is hit. War is started without asking.++-- | This function implements the actual logic of running. It checks if we+-- have to stop running because something interesting cropped up,+-- it ajusts the direction given by the vector if we reached+-- a corridor's corner (we never change direction except in corridors)+-- and it increments the counter of traversed tiles.+--+-- Note that while goto-xhair commands ignore items on the way,+-- here we stop wnenever we touch an item. Running is more cautious+-- to compensate that the player cannot specify the end-point of running.+-- It's also more suited to open, already explored terrain. Goto-xhair+-- works better with unknown terrain, e.g., it stops whenever an item+-- is spotted, but then ignores the item, leaving it to the player+-- to mark the item position as a goal of the next goto.+continueRunDir :: MonadClientUI m+               => RunParams -> m (Either Text Vector)+continueRunDir params = case params of+  RunParams{ runMembers = [] } -> error $ "" `showFailure` params+  RunParams{ runLeader+           , runMembers = aid : _+           , runInitial } -> do+    report <- getsSession $ newReport . shistory+    let msgInterrupts = anyInReport interruptsRunning report+    if msgInterrupts then return $ Left "message shown"+    else do+      cops@COps{coTileSpeedup} <- getsState scops+      rbody <- getsState $ getActorBody runLeader+      let rposHere = bpos rbody+          rposLast = fromMaybe (error $ "" `showFailure` (runLeader, rbody))+                               (boldpos rbody)+          -- Match run-leader dir, because we want runners to keep formation.+          dir = rposHere `vectorToFrom` rposLast+      body <- getsState $ getActorBody aid+      let lid = blid body+      lvl <- getLevel lid+      let posHere = bpos body+          posThere = posHere `shift` dir+          bigActorThere = occupiedBigLvl posThere lvl+          projsThere = occupiedProjLvl posThere lvl+      let openableLast =+            Tile.isOpenable coTileSpeedup (lvl `at` (posHere `shift` dir))+          check+            | bigActorThere = return $ Left "actor in the way"+            | projsThere = return $ Left "projectile in the way"+                -- don't displace actors, except with leader in step 0+            | walkableDir cops lvl posHere dir =+                if runInitial && aid /= runLeader+                then return $ Right dir  -- zeroth step always OK+                else checkAndRun aid dir+            | not (runInitial && aid == runLeader) = return $ Left "blocked"+                -- don't change direction, except in step 1 and by run-leader+            | openableLast = return $ Left "blocked by a closed door"+                -- the player may prefer to open the door+            | otherwise =+                -- Assume turning is permitted, because this is the start+                -- of the run, so the situation is mostly known to the player+                tryTurning aid+      check++walkableDir :: COps -> Level -> Point -> Vector -> Bool+walkableDir COps{coTileSpeedup} lvl spos dir =+  Tile.isWalkable coTileSpeedup $ lvl `at` (spos `shift` dir)++tryTurning :: MonadClientRead m+           => ActorId -> m (Either Text Vector)+tryTurning aid = do+  cops@COps{coTileSpeedup} <- getsState scops+  body <- getsState $ getActorBody aid+  let lid = blid body+  lvl <- getLevel lid+  let posHere = bpos body+      posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body)+      dirLast = posHere `vectorToFrom` posLast+  let openableDir dir =+        Tile.isOpenable coTileSpeedup (lvl `at` (posHere `shift` dir))+      dirWalkable dir = walkableDir cops lvl posHere dir || openableDir dir+      dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 == 1+      -- Distance 2 could be useful, but surprising even to apt players.+      dirSimilar dir = dirNearby dirLast dir && dirWalkable dir+      dirsSimilar = filter dirSimilar moves+  case dirsSimilar of+    [] -> return $ Left "dead end"+    d1 : ds | all (dirNearby d1) ds ->  -- only one or two directions possible+      case sortOn (euclidDistSqVector dirLast)+           $ filter (walkableDir cops lvl posHere) $ d1 : ds of+        [] ->+          return $ Left "blocked and all similar directions are non-walkable"+        d : _ -> checkAndRun aid d+    _ -> return $ Left "blocked and many distant similar directions found"++-- The direction is different than the original, if called from @tryTurning@+-- and the same if from @continueRunDir@.+checkAndRun :: MonadClientRead m+            => ActorId -> Vector -> m (Either Text Vector)+checkAndRun aid dir = do+  COps{coTileSpeedup} <- getsState scops+  actorMaxSkills <- getsState sactorMaxSkills+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  smarkSuspect <- getsClient smarkSuspect+  let lid = blid body+  lvl <- getLevel lid+  actorD <- getsState sactorD+  let posHere = bpos body+      posHasItems pos = EM.member pos $ lfloor lvl+      posThere = posHere `shift` dir+      bigActorThere = occupiedBigLvl posThere lvl+      enemyThreatensThere =+        let f !p = case posToBigLvl p lvl of+                Nothing -> False+                Just aid2 -> g aid2 $ actorD EM.! aid2+            g aid2 !b2 = inline isFoe (bfid body) fact (bfid b2)+                         && actorCanMeleeToHarm actorMaxSkills aid2 b2+                         && bhp b2 > 0  -- uncommon+        in any f $ vicinityUnsafe posThere+      projsThere = occupiedProjLvl posThere lvl+  let posLast = fromMaybe (error $ "" `showFailure` (aid, body)) (boldpos body)+      dirLast = posHere `vectorToFrom` posLast+      -- This is supposed to work on unit vectors --- diagonal, as well as,+      -- vertical and horizontal.+      anglePos :: Point -> Vector -> RadianAngle -> Point+      anglePos pos d angle = shift pos (rotate angle d)+      -- We assume the tiles have not changed since last running step.+      -- If they did, we don't care --- running should be stopped+      -- because of the change of nearby tiles then.+      -- We don't take into account the two tiles at the rear of last+      -- surroundings, because the actor may have come from there+      -- (via a diagonal move) and if so, he may be interested in such tiles.+      -- If he arrived directly from the right or left, he is responsible+      -- for starting the run further away, if he does not want to ignore+      -- such tiles as the ones he came from.+      tileLast = lvl `at` posLast+      tileHere = lvl `at` posHere+      tileThere = lvl `at` posThere+      leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]+                   ++ map (anglePos posHere dir) [pi/2, 3*pi/4]+      rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]+                    ++ map (anglePos posHere dir) [-pi/2, -3*pi/4]+      leftForwardPosHere = anglePos posHere dir (pi/4)+      rightForwardPosHere = anglePos posHere dir (-pi/4)+      leftTilesLast = map (lvl `at`) leftPsLast+      rightTilesLast = map (lvl `at`) rightPsLast+      leftForwardTileHere = lvl `at` leftForwardPosHere+      rightForwardTileHere = lvl `at` rightForwardPosHere+      tilePropAt :: ContentId TileKind -> (Bool, Bool, Bool, Bool, Bool, Bool)+      tilePropAt tile =+        let suspect =+              smarkSuspect > 0 && Tile.isSuspect coTileSpeedup tile+              || smarkSuspect > 1 && Tile.isHideAs coTileSpeedup tile+            embed = Tile.isEmbed coTileSpeedup tile  -- no matter if embeds left+            walkable = Tile.isWalkable coTileSpeedup tile+            openable = Tile.isOpenable coTileSpeedup tile+            closable = Tile.isClosable coTileSpeedup tile+            modifiable = Tile.isModifiable coTileSpeedup tile+        in (suspect, embed, walkable, openable, closable, modifiable)+      terrainChangeMiddle = tilePropAt tileThere+                            `notElem` map tilePropAt [tileLast, tileHere]+      terrainChangeLeft = tilePropAt leftForwardTileHere+                          `notElem` map tilePropAt leftTilesLast+      terrainChangeRight = tilePropAt rightForwardTileHere+                           `notElem` map tilePropAt rightTilesLast+      itemChangeLeft = posHasItems leftForwardPosHere+                       `notElem` map posHasItems leftPsLast+      itemChangeRight = posHasItems rightForwardPosHere+                        `notElem` map posHasItems rightPsLast+      check+        | bigActorThere = return $ Left "actor in the way"+        | enemyThreatensThere = return $ Left "enemy threatens the position"+        | projsThere = return $ Left "projectile in the way"+            -- Actor in possibly another direction tnan original.+            -- (e.g., called from @tryTurning@).+        | terrainChangeLeft = return $ Left "terrain change on the left"+        | terrainChangeRight = return $ Left "terrain change on the right"+        | itemChangeLeft = return $ Left "item change on the left"+        | itemChangeRight = return $ Left "item change on the right"+        | terrainChangeMiddle = return $ Left "terrain change in the middle"+        | otherwise = return $ Right dir+  check
+ engine-src/Game/LambdaHack/Client/UI/SessionUI.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | The client UI session state.+module Game.LambdaHack.Client.UI.SessionUI+  ( SessionUI(..), ReqDelay(..), ItemDictUI, ItemRoles(..), AimMode(..)+  , KeyMacro(..), KeyMacroFrame(..), RunParams(..), ChosenLore(..)+  , emptySessionUI, emptyMacroFrame+  , cycleMarkVision, toggleMarkSmell, cycleOverrideTut, getActorUI+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import           Data.Time.Clock.POSIX+import           GHC.Generics (Generic)+import qualified System.Random.SplitMix32 as SM++import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.EffectDescription (DetailLevel (..))+import           Game.LambdaHack.Client.UI.Frontend+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.ModeKind (ModeKind)+import           Game.LambdaHack.Definition.Defs++-- | The information that is used across a human player playing session,+-- including many consecutive games in a single session,+-- including playing different teams. Some of it is saved, some is reset+-- when a new playing session starts. Nothing is tied to a faction/team,+-- but instead all to UI configuration and UI input and display history.+-- An important component is the frontend session.+data SessionUI = SessionUI+  { sreqPending    :: Maybe RequestUI+                                    -- ^ request created by a UI query+                                    --   but not yet sent to the server+  , sreqDelay      :: ReqDelay      -- ^ server delayed sending query to client+                                    --   or receiving request from client+  , sreqQueried    :: Bool          -- ^ player is now queried for a command+  , sregainControl :: Bool          -- ^ player requested to regain control+                                    --   from AI ASAP+  , sxhair         :: Maybe Target  -- ^ the common xhair+  , sxhairGoTo     :: Maybe Target  -- ^ xhair set for last GoTo+  , sactorUI       :: ActorDictUI   -- ^ assigned actor UI presentations+  , sitemUI        :: ItemDictUI    -- ^ assigned item first seen level+  , sroles         :: ItemRoles     -- ^ assignment of roles to items+  , slastItemMove  :: Maybe (CStore, CStore)+                                    -- ^ last item move stores+  , schanF         :: ChanFrontend  -- ^ connection with the frontend+  , sccui          :: CCUI          -- ^ UI client content+  , sUIOptions     :: UIOptions     -- ^ UI options as set by the player+  , saimMode       :: Maybe AimMode -- ^ aiming mode+  , sxhairMoused   :: Bool          -- ^ last mouse aiming not vacuus+  , sitemSel       :: Maybe (ItemId, CStore, Bool)+                                    -- ^ selected item, if any, it's store and+                                    --   whether to override suitability check+  , sselected      :: ES.EnumSet ActorId+                                    -- ^ the set of currently selected actors+  , srunning       :: Maybe RunParams+                                    -- ^ parameters of the current run, if any+  , shistory       :: History       -- ^ history of messages+  , svictories     :: EM.EnumMap (ContentId ModeKind) (M.Map Challenge Int)+      -- ^ the number of games won by the UI faction per game mode+      --   and per difficulty level+  , scampings      :: ES.EnumSet (ContentId ModeKind)  -- ^ camped games+  , srestarts      :: ES.EnumSet (ContentId ModeKind)  -- ^ restarted games+  , spointer       :: PointUI       -- ^ mouse pointer position+  , sautoYes       :: Bool          -- ^ whether to auto-clear prompts+  , smacroFrame    :: KeyMacroFrame -- ^ the head of the key macro stack+  , smacroStack    :: [KeyMacroFrame]+                                    -- ^ the tail of the key macro stack+  , slastLost      :: ES.EnumSet ActorId+                                    -- ^ actors that just got out of sight+  , swaitTimes     :: Int           -- ^ player just waited this many times+  , swasAutomated  :: Bool          -- ^ the player just exited AI automation+  , smarkVision    :: Int           -- ^ mark leader and party FOV+  , smarkSmell     :: Bool          -- ^ mark smell, if the leader can smell+  , snxtScenario   :: Int           -- ^ next game scenario number+  , scurTutorial   :: Bool          -- ^ whether current game is a tutorial+  , snxtTutorial   :: Bool          -- ^ whether next game is to be tutorial+  , soverrideTut   :: Maybe Bool    -- ^ override display of tutorial hints+  , susedHints     :: S.Set Msg     -- ^ tutorial hints already shown this game+  , smuteMessages  :: Bool          -- ^ whether to mute all new messages+  , smenuIxMap     :: M.Map String Int+                                    -- ^ indices of last used menu items+  , schosenLore    :: ChosenLore    -- ^ last lore chosen to display+  , sdisplayNeeded :: Bool          -- ^ current level needs displaying+  , sturnDisplayed :: Bool          -- ^ a frame was already displayed this turn+  , sreportNull    :: Bool          -- ^ whether no visible report created+                                    --   last UI faction turn or the report+                                    --   wiped out from screen since+  , sstart         :: POSIXTime     -- ^ this session start time+  , sgstart        :: POSIXTime     -- ^ this game start time+  , sallTime       :: Time          -- ^ clips from start of session+                                    --   to current game start+  , snframes       :: Int           -- ^ this game current frame count+  , sallNframes    :: Int           -- ^ frame count from start of session+                                    --   to current game start+  , srandomUI      :: SM.SMGen      -- ^ current random generator for UI+  }++data ReqDelay = ReqDelayNot | ReqDelayHandled | ReqDelayAlarm+  deriving Eq++-- | Local macro buffer frame. Predefined macros have their own in-game macro+-- buffer, allowing them to record in-game macro, queue actions and repeat+-- the last macro's action.+-- Running predefined macro pushes new @KeyMacroFrame@ onto the stack. We pop+-- buffers from the stack if locally there are no actions pending to be handled.+data KeyMacroFrame = KeyMacroFrame+  { keyMacroBuffer :: Either [K.KM] KeyMacro -- ^ record keystrokes in Left;+                                             --   repeat from Right+  , keyPending     :: KeyMacro               -- ^ actions pending to be handled+  , keyLast        :: Maybe K.KM             -- ^ last pressed key+  } deriving Show++-- This can stay a map forever, not a vector, because it's added to often,+-- but never read from, except when the user requests item details.+type ItemDictUI = EM.EnumMap ItemId LevelId++-- | A collection of item identifier sets indicating what roles (possibly many)+-- an item has assigned.+newtype ItemRoles = ItemRoles (EM.EnumMap SLore (ES.EnumSet ItemId))+  deriving (Show, Binary)++-- | Current aiming mode of a client.+data AimMode = AimMode+  { aimLevelId  :: LevelId+  , detailLevel :: DetailLevel+  }+  deriving (Show, Eq, Generic)++instance Binary AimMode++-- | In-game macros. We record menu navigation keystrokes and keystrokes+-- bound to commands with one exception --- we exclude keys that invoke+-- the @Record@ command, to avoid surprises.+-- Keys are kept in the same order in which they're meant to be replayed,+-- i.e. the first element of the list is replayed also as the first one.+newtype KeyMacro = KeyMacro {unKeyMacro :: [K.KM]}+  deriving (Show, Eq, Binary, Semigroup, Monoid)++-- | Parameters of the current run.+data RunParams = RunParams+  { runLeader  :: ActorId         -- ^ the original leader from run start+  , runMembers :: [ActorId]       -- ^ the list of actors that take part+  , runInitial :: Bool            -- ^ initial run continuation by any+                                  --   run participant, including run leader+  , runStopMsg :: Maybe Text      -- ^ message with the next stop reason+  , runWaiting :: Int             -- ^ waiting for others to move out of the way+  }+  deriving Show++-- | Last lore being aimed at.+data ChosenLore =+    ChosenLore [(ActorId, Actor)] [(ItemId, ItemQuant)]+  | ChosenNothing++emptySessionUI :: UIOptions -> SessionUI+emptySessionUI sUIOptions =+  SessionUI+    { sreqPending = Nothing+    , sreqDelay = ReqDelayNot+    , sreqQueried = False+    , sregainControl = False+    , sxhair = Nothing+    , sxhairGoTo = Nothing+    , sactorUI = EM.empty+    , sitemUI = EM.empty+    , sroles = ItemRoles $ EM.fromDistinctAscList+               $ zip [minBound..maxBound] (repeat ES.empty)+    , slastItemMove = Nothing+    , schanF = ChanFrontend $ const $+        error $ "emptySessionUI: ChanFrontend" `showFailure` ()+    , sccui = emptyCCUI+    , sUIOptions+    , saimMode = Nothing+    , sxhairMoused = True+    , sitemSel = Nothing+    , sselected = ES.empty+    , srunning = Nothing+    , shistory = emptyHistory 0+    , svictories = EM.empty+    , scampings = ES.empty+    , srestarts = ES.empty+    , spointer = PointUI 0 0+    , sautoYes = False+    , smacroFrame = emptyMacroFrame+    , smacroStack = []+    , slastLost = ES.empty+    , swaitTimes = 0+    , swasAutomated = False+    , smarkVision = 1+    , smarkSmell = True+    , snxtScenario = 0+    , scurTutorial = False+    , snxtTutorial = True  -- matches @snxtScenario = 0@+    , soverrideTut = Nothing+    , susedHints = S.empty+    , smuteMessages = False+    , smenuIxMap = M.empty+    , schosenLore = ChosenNothing+    , sdisplayNeeded = False+    , sturnDisplayed = False+    , sreportNull = True+    , sstart = 0+    , sgstart = 0+    , sallTime = timeZero+    , snframes = 0+    , sallNframes = 0+    , srandomUI = SM.mkSMGen 0+    }++emptyMacroFrame :: KeyMacroFrame+emptyMacroFrame = KeyMacroFrame (Right mempty) mempty Nothing++cycleMarkVision :: Int -> SessionUI -> SessionUI+cycleMarkVision delta sess =+  sess {smarkVision = (smarkVision sess + delta) `mod` 3}++toggleMarkSmell :: SessionUI -> SessionUI+toggleMarkSmell sess = sess {smarkSmell = not (smarkSmell sess)}++cycleOverrideTut :: Int -> SessionUI -> SessionUI+cycleOverrideTut delta sess =+  let ordering = cycle [Nothing, Just False, Just True]+  in sess {soverrideTut =+    let ix = fromJust $ elemIndex (soverrideTut sess) ordering+    in ordering !! (ix + delta)}++getActorUI :: ActorId -> SessionUI -> ActorUI+getActorUI aid sess =+  EM.findWithDefault (error $ "" `showFailure` (aid, sactorUI sess)) aid+  $ sactorUI sess++instance Binary SessionUI where+  put SessionUI{..} = do+    put sxhair+    put sactorUI+    put sitemUI+    put sroles+    put sUIOptions+    put saimMode+    put sitemSel+    put sselected+    put srunning+    put $ archiveReport shistory+      -- avoid displaying ending messages again at game start+    put svictories+    put scampings+    put srestarts+    put smarkVision+    put smarkSmell+    put snxtScenario+    put scurTutorial+    put snxtTutorial+    put soverrideTut+    put susedHints+    put (show srandomUI)+  get = do+    sxhair <- get+    sactorUI <- get+    sitemUI <- get+    sroles <- get+    sUIOptions <- get  -- is overwritten ASAP, but useful for, e.g., crash debug+    saimMode <- get+    sitemSel <- get+    sselected <- get+    srunning <- get+    shistory <- get+    svictories <- get+    scampings <- get+    srestarts <- get+    smarkVision <- get+    smarkSmell <- get+    snxtScenario <- get+    scurTutorial <- get+    snxtTutorial <- get+    soverrideTut <- get+    susedHints <- get+    g <- get+    let sreqPending = Nothing+        sreqDelay = ReqDelayNot+        sreqQueried = False+        sregainControl = False+        sxhairGoTo = Nothing+        slastItemMove = Nothing+        schanF = ChanFrontend $ const $+          error $ "Binary: ChanFrontend" `showFailure` ()+        sccui = emptyCCUI+        sxhairMoused = True+        spointer = PointUI 0 0+        sautoYes = False+        smacroFrame = emptyMacroFrame+        smacroStack = []+        slastLost = ES.empty+        swaitTimes = 0+        swasAutomated = False+        smuteMessages = False+        smenuIxMap = M.empty+        schosenLore = ChosenNothing+        sdisplayNeeded = False  -- displayed regardless+        sturnDisplayed = False+        sreportNull = True+        sstart = 0+        sgstart = 0+        sallTime = timeZero+        snframes = 0+        sallNframes = 0+        srandomUI = read g+    return $! SessionUI{..}++instance Binary RunParams where+  put RunParams{..} = do+    put runLeader+    put runMembers+    put runInitial+    put runStopMsg+    put runWaiting+  get = do+    runLeader <- get+    runMembers <- get+    runInitial <- get+    runStopMsg <- get+    runWaiting <- get+    return $! RunParams{..}
+ engine-src/Game/LambdaHack/Client/UI/Slideshow.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Slideshows.+module Game.LambdaHack.Client.UI.Slideshow+  ( FontOverlayMap, maxYofFontOverlayMap+  , KeyOrSlot, MenuSlot, natSlots+  , ButtonWidth(..)+  , KYX, xytranslateKXY, xtranslateKXY, ytranslateKXY, yrenumberKXY+  , OKX, emptyOKX, xytranslateOKX, sideBySideOKX, labDescOKX+  , Slideshow(slideshow), emptySlideshow, unsnocSlideshow, toSlideshow+  , attrLinesToFontMap, menuToSlideshow, wrapOKX, splitOverlay, splitOKX+  , highSlideshow+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , keysOKX, showTable, showNearbyScores+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import           Data.Time.LocalTime++import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import qualified Game.LambdaHack.Common.HighScore as HighScore+import qualified Game.LambdaHack.Definition.Color as Color++type FontOverlayMap = EM.EnumMap DisplayFont Overlay++maxYofFontOverlayMap :: FontOverlayMap -> Int+maxYofFontOverlayMap ovs = maximum (0 : map maxYofOverlay (EM.elems ovs))++type KeyOrSlot = Either K.KM MenuSlot++newtype MenuSlot = MenuSlot Int+  deriving (Show, Eq, Ord, Binary, Enum)++natSlots :: [MenuSlot]+{-# INLINE natSlots #-}+natSlots = [MenuSlot 0 ..]++-- TODO: probably best merge the PointUI into that and represent+-- the position as characters, too, translating to UI positions as needed.+-- The problem is that then I need to do a lot of reverse translation+-- when creating buttons.+-- | Width of on-screen button text, expressed in characters,+-- and so UI (mono font) width is deduced from the used font.+data ButtonWidth = ButtonWidth+  { buttonFont  :: DisplayFont+  , buttonWidth :: Int }+  deriving (Show, Eq)++-- | A key or a menu slot at a given position on the screen.+type KYX = (KeyOrSlot, (PointUI, ButtonWidth))++xytranslateKXY :: Int -> Int -> KYX -> KYX+xytranslateKXY dx dy (km, (PointUI x y, len)) =+  (km, (PointUI (x + dx) (y + dy), len))++xtranslateKXY :: Int -> KYX -> KYX+xtranslateKXY dx = xytranslateKXY dx 0++ytranslateKXY :: Int -> KYX -> KYX+ytranslateKXY = xytranslateKXY 0++yrenumberKXY :: Int -> KYX -> KYX+yrenumberKXY ynew (km, (PointUI x _, len)) = (km, (PointUI x ynew, len))++-- | An Overlay of text with an associated list of keys or slots+-- that activate when the specified screen position is pointed at.+-- The list should be sorted wrt rows and then columns.+type OKX = (FontOverlayMap, [KYX])++emptyOKX :: OKX+emptyOKX = (EM.empty, [])++xytranslateOKX ::Int -> Int -> OKX -> OKX+xytranslateOKX dx dy (ovs, kyxs) =+  ( EM.map (xytranslateOverlay dx dy) ovs+  , map (xytranslateKXY dx dy) kyxs )++sideBySideOKX :: Int -> Int -> OKX -> OKX -> OKX+sideBySideOKX dx dy (ovs1, kyxs1) (ovs2, kyxs2) =+  let (ovs3, kyxs3) = xytranslateOKX dx dy (ovs2, kyxs2)+  in ( EM.unionWith (++) ovs1 ovs3+     , sortOn (\(_, (PointUI x y, _)) -> (y, x)) $ kyxs1 ++ kyxs3 )++-- The bangs are to free the possibly very long input list ASAP.+labDescOKX :: DisplayFont -> DisplayFont+           -> [(AttrString, AttrString, KeyOrSlot)]+           -> OKX+labDescOKX labFont descFont l =+  let descFontSize | isPropFont descFont = length  -- may be less or a bit more+                   | otherwise = textSize descFont+      processRow :: (AttrString, AttrString, KeyOrSlot)+                 -> (AttrLine, (Int, AttrLine), KYX)+      processRow (!tLab, !tDesc, !ekm) =+        let labLen = textSize labFont tLab+            lenButton = labLen + descFontSize tDesc+        in ( attrStringToAL tLab+           , (labLen, attrStringToAL tDesc)+           , (ekm, (PointUI 0 0, ButtonWidth descFont lenButton)) )+      (tsLab, tsDesc, kxs) = unzip3 $ map processRow l+      ovs = EM.insertWith (++) labFont (offsetOverlay tsLab)+            $ EM.singleton descFont $ offsetOverlayX tsDesc+  in (ovs, zipWith yrenumberKXY [0..] kxs)++-- | A list of active screenfulls to be shown one after another.+-- Each screenful has an independent numbering of rows and columns.+newtype Slideshow = Slideshow {slideshow :: [OKX]}+  deriving (Show, Eq)++emptySlideshow :: Slideshow+emptySlideshow = Slideshow []++unsnocSlideshow :: Slideshow -> Maybe (Slideshow, OKX)+unsnocSlideshow Slideshow{slideshow} =+  case reverse slideshow of+    [] -> Nothing+    okx : rest -> Just (Slideshow $ reverse rest, okx)++toSlideshow :: FontSetup -> Bool -> [OKX] -> Slideshow+toSlideshow FontSetup{..}displayTutorialHints okxs =+  Slideshow $ addFooters False okxs+ where+  atEnd = flip (++)+  appendToFontOverlayMap :: FontOverlayMap -> String+                         -> (FontOverlayMap, PointUI, DisplayFont, Int)+  appendToFontOverlayMap ovs msgPrefix =+    let msg | displayTutorialHints =+              msgPrefix+              ++ "  (ESC to exit, PGUP, HOME, mouse, wheel, arrows, etc.)"+            | otherwise = msgPrefix+        maxYminXofOverlay ov =+          let ymxOfOverlay (PointUI x y, _) = (- y, x)+          in minimum $ maxBound : map ymxOfOverlay ov+        -- @sortOn@ less efficient here, because function cheap.+        assocsYX = sortBy (comparing snd)+                   $ EM.assocs $ EM.map maxYminXofOverlay ovs+        (fontMax, yMax) = case assocsYX of+          [] -> (monoFont, 0)+          (font, (yNeg, _x)) : rest ->+            let unique = all (\(_, (yNeg2, _)) -> yNeg /= yNeg2) rest+            in ( if isSquareFont font && unique+                 then font+                 else monoFont+               , - yNeg )+        pMax = PointUI 0 (yMax + 1)  -- append after last line+    in ( EM.insertWith atEnd fontMax [(pMax, stringToAL msg)] ovs+       , pMax+       , fontMax+       , length msg )+  addFooters :: Bool -> [OKX] -> [OKX]+  addFooters _ [] = error $ "" `showFailure` okxs+  addFooters _ [(als, [])] =+    -- TODO: make sure this case never coincides with the space button+    -- actually returning to top, as opposed to finishing preview.+    let (ovs, p, font, width) = appendToFontOverlayMap als "--end--"+    in [(ovs, [(Left K.safeSpaceKM, (p, ButtonWidth font width))])]+  addFooters False [(als, kxs)] = [(als, kxs)]+  addFooters True [(als, kxs)] =+    let (ovs, p, font, width) = appendToFontOverlayMap als "--back to top--"+    in [(ovs, kxs ++ [(Left K.safeSpaceKM, (p, ButtonWidth font width))])]+  addFooters _ ((als, kxs) : rest) =+    let (ovs, p, font, width) = appendToFontOverlayMap als "--more--"+    in (ovs, kxs ++ [(Left K.safeSpaceKM, (p, ButtonWidth font width))])+       : addFooters True rest++-- | This appends vertically a list of blurbs into a single font overlay map.+-- Not to be used if some blurbs need to be places overlapping vertically,+-- e.g., when the square font symbol needs to be in the same line+-- as the start of the descritpion of the denoted item+-- or when mono font buttons need to be after a prompt.+attrLinesToFontMap :: [(DisplayFont, [AttrLine])] -> FontOverlayMap+attrLinesToFontMap blurb =+  let zipAttrLines :: Int -> [AttrLine] -> (Overlay, Int)+      zipAttrLines start als =+        ( zipWith (curry (first $ PointUI 0)) [start ..] als+        , start + length als )+      addOverlay :: (FontOverlayMap, Int) -> (DisplayFont, [AttrLine])+                 -> (FontOverlayMap, Int)+      addOverlay (!em, !start) (font, als) =+        let (als2, start2) = zipAttrLines start als+        in ( EM.insertWith (++) font als2 em+           , start2 )+      (ov, _) = foldl' addOverlay (EM.empty, 0) blurb+  in ov++menuToSlideshow :: OKX -> Slideshow+menuToSlideshow (als, kxs) =+  assert (not (EM.null als || null kxs)) $ Slideshow [(als, kxs)]++wrapOKX :: DisplayFont -> Int -> Int -> Int -> [(K.KM, String)]+        -> (Overlay, [KYX])+wrapOKX _ _ _ _ [] = ([], [])+wrapOKX displayFont ystart xstart width ks =+  let overlayLineFromStrings :: Int -> Int -> [String] -> (PointUI, AttrLine)+      overlayLineFromStrings xlineStart y strings =+        let p = PointUI xlineStart y+        in (p, stringToAL $ unwords (reverse strings))+      f :: ((Int, Int), (Int, [String], Overlay, [KYX])) -> (K.KM, String)+        -> ((Int, Int), (Int, [String], Overlay, [KYX]))+      f ((y, x), (xlineStart, kL, kV, kX)) (key, s) =+        let len = textSize displayFont s+            len1 = len + textSize displayFont " "+        in if x + len >= width+           then let iov = overlayLineFromStrings xlineStart y kL+                in f ((y + 1, 0), (0, [], iov : kV, kX)) (key, s)+           else ( (y, x + len1)+                , ( xlineStart+                  , s : kL+                  , kV+                  , (Left key, ( PointUI x y+                               , ButtonWidth displayFont (length s) ))+                    : kX ) )+      ((ystop, _), (xlineStop, kL1, kV1, kX1)) =+        foldl' f ((ystart, xstart), (xstart, [], [], [])) ks+      iov1 = overlayLineFromStrings xlineStop ystop kL1+  in (reverse $ iov1 : kV1, reverse kX1)++keysOKX :: DisplayFont -> Int -> Int -> Int -> [K.KM] -> (Overlay, [KYX])+keysOKX displayFont ystart xstart width keys =+  let wrapB :: String -> String+      wrapB s = "[" ++ s ++ "]"+      ks = map (\key -> (key, wrapB $ K.showKM key)) keys+  in wrapOKX displayFont ystart xstart width ks++-- The font argument is for the report and keys overlay. Others already have+-- assigned fonts.+splitOverlay :: FontSetup -> Bool -> Int -> Int -> Int -> Report -> [K.KM]+             -> OKX+             -> Slideshow+splitOverlay fontSetup displayTutorialHints+             width height wrap report keys (ls0, kxs0) =+  let renderedReport = renderReport True report+      reportAS = foldr (<\:>) [] renderedReport+  in toSlideshow fontSetup displayTutorialHints $+       splitOKX fontSetup False width height wrap reportAS keys (ls0, kxs0)++-- Note that we only split wrt @White@ space, nothing else.+splitOKX :: FontSetup -> Bool -> Int -> Int -> Int -> AttrString -> [K.KM]+         -> OKX+         -> [OKX]+splitOKX FontSetup{..} msgLong width height wrap reportAS keys (ls0, kxs0) =+  assert (width > 2 && height > 2) $+    -- if the strings to split are long these minimums won't be enough,+    -- but content validation ensures larger values (perhaps large enough?)+  let reportParagraphs = linesAttr reportAS+      -- TODO: until SDL support for measuring prop font text is released,+      -- we have to use MonoFont for the paragraph that ends with buttons.+      (repProp, repMono) =+        if null keys+        then (reportParagraphs, emptyAttrLine)+        else case reverse reportParagraphs of+          [] -> ([], emptyAttrLine)+          l : rest ->+            (reverse rest, attrStringToAL $ attrLine l ++ [Color.nbspAttrW32])+      msgWrap = if msgLong && not (isSquareFont propFont)+                then 2 * width+                else wrap  -- TODO if with width fits on one screen, use it+      msgWidth = if msgLong && not (isSquareFont propFont)+                 then 2 * width+                 else width+      repProp0 = offsetOverlay $ case repProp of+        [] -> []+        r : rs ->+          -- Make lines of first paragraph long if it has 2 lines at most.+          -- The first line does not obscure anything and the second line+          -- is often short anyway.+          let firstWidth = if length (attrLine r) <= 2 * msgWidth+                           then msgWidth+                           else msgWrap+          in (indentSplitAttrString propFont firstWidth . attrLine) r+               -- first possibly long+             ++ concatMap (indentSplitAttrString propFont msgWrap . attrLine) rs+      -- TODO: refactor this ugly pile of copy-paste+      repPropW = offsetOverlay+                 $ concatMap (indentSplitAttrString propFont width . attrLine)+                             repProp+      -- If the mono portion first on the line, let it take half width,+      -- but if previous lines shorter, match them and only buttons+      -- are permitted to stick out.+      monoWidth = if null repProp then msgWidth else msgWrap+      repMono0 = ytranslateOverlay (length repProp0)+                 $ offsetOverlay+                 $ indentSplitAttrString monoFont monoWidth $ attrLine repMono+      repMonoW = ytranslateOverlay (length repPropW)+                 $ offsetOverlay+                 $ indentSplitAttrString monoFont width $ attrLine repMono+      repWhole0 = offsetOverlay+                  $ concatMap (indentSplitAttrString propFont msgWidth+                               . attrLine)+                              reportParagraphs+      repWhole1 = ytranslateOverlay 1 repWhole0+      lenOfRep0 = length repProp0 + length repMono0+      lenOfRepW = length repPropW + length repMonoW+      startOfKeys = if null repMono0+                    then 0+                    else textSize monoFont (attrLine $ snd $ last repMono0)+      startOfKeysW = if null repMonoW+                     then 0+                     else textSize monoFont (attrLine $ snd $ last repMonoW)+      pressAKey = stringToAS "A long report is shown. Press a key:"+                  ++ [Color.nbspAttrW32]+      (lX0, keysX0) = keysOKX monoFont 0 (length pressAKey) width keys+      (lX1, keysX1) = keysOKX monoFont 1 0 width keys+      (lX, keysX) = keysOKX monoFont (max 0 $ lenOfRep0 - 1) startOfKeys+                            (2 * width) keys+      (lXW, keysXW) = keysOKX monoFont (max 0 $ lenOfRepW - 1) startOfKeysW+                              (2 * width) keys+      splitO :: Int -> (Overlay, Overlay, [KYX]) -> OKX -> [OKX]+      splitO yoffset (hdrProp, hdrMono, rk) (ls, kxs) =+        let hdrOff | null hdrProp && null hdrMono = 0+                   | otherwise = 1 + maxYofOverlay hdrMono+            keyTranslate = map $ ytranslateKXY (hdrOff - yoffset)+            lineTranslate = EM.map $ ytranslateOverlay (hdrOff - yoffset)+            yoffsetNew = yoffset + height - hdrOff - 1+            ltOffset :: (PointUI, a) -> Bool+            ltOffset (PointUI _ y, _) = y < yoffsetNew+            (pre, post) = ( filter ltOffset <$> ls+                          , filter (not . ltOffset) <$> ls )+            prependHdr = EM.insertWith (++) propFont hdrProp+                         . EM.insertWith (++) monoFont hdrMono+        in if all null $ EM.elems post  -- all fits on one screen+           then [(prependHdr $ lineTranslate pre, rk ++ keyTranslate kxs)]+           else let (preX, postX) = span (\(_, pa) -> ltOffset pa) kxs+                in (prependHdr $ lineTranslate pre, rk ++ keyTranslate preX)+                   : splitO yoffsetNew (hdrProp, hdrMono, rk) (post, postX)+      firstParaReport = firstParagraph reportAS+      hdrShortened = ( [(PointUI 0 0, firstParaReport)]+                         -- shortened for the main slides; in full beforehand+                     , take 3 lX1  -- 3 lines ought to be enough for everyone+                     , keysX1 )+      ((lsInit, kxsInit), (headerProp, headerMono, rkxs)) =+        -- Check whether all space taken by report and keys.+        if | (lenOfRep0 + length lX) < height ->  -- display normally+             (emptyOKX, (repProp0, lX ++ repMono0, keysX))+           | (lenOfRepW + length lXW) < height ->  -- display widely+             (emptyOKX, (repPropW, lXW ++ repMonoW, keysXW))+           | length reportParagraphs == 1+             && length (attrLine firstParaReport) <= 2 * width ->+             ( emptyOKX  -- already shown in full in @hdrShortened@+             , hdrShortened )+           | otherwise -> case lX0 of+               [] ->+                 ( (EM.singleton propFont repWhole0, [])+                     -- showing in full in the init slide+                 , hdrShortened )+               lX0first : _ ->+                 ( ( EM.insertWith (++) propFont repWhole1+                     $ EM.singleton monoFont+                         [(PointUI 0 0, firstParagraph pressAKey), lX0first]+                   , filter (\(_, (PointUI _ y, _)) -> y == 0) keysX0 )+                 , hdrShortened )+      initSlides = if EM.null lsInit+                   then assert (null kxsInit) []+                   else splitO 0 ([], [], []) (lsInit, kxsInit)+      -- If @ls0@ is not empty, we still want to display the report,+      -- one way or another.+      mainSlides = if EM.null ls0 && not (EM.null lsInit)+                   then assert (null kxs0) []+                   else splitO 0 (headerProp, headerMono, rkxs) (ls0, kxs0)+  in initSlides ++ mainSlides++-- | Generate a slideshow with the current and previous scores.+highSlideshow :: FontSetup+              -> Bool+              -> Int        -- ^ width of the display area+              -> Int        -- ^ height of the display area+              -> HighScore.ScoreTable -- ^ current score table+              -> Int        -- ^ position of the current score in the table+              -> Text       -- ^ the name of the game mode+              -> TimeZone   -- ^ the timezone where the game is run+              -> Slideshow+highSlideshow fontSetup@FontSetup{monoFont} displayTutorialHints+              width height table pos gameModeName tz =+  let entries = (height - 3) `div` 3+      msg = HighScore.showAward entries table pos gameModeName+      tts = map offsetOverlay $ showNearbyScores tz pos table entries+      al = textToAS msg+      splitScreen ts =+        splitOKX fontSetup False width height width al [K.spaceKM, K.escKM]+                 (EM.singleton monoFont ts, [])+  in toSlideshow fontSetup displayTutorialHints $ concatMap splitScreen tts++-- | Show a screenful of the high scores table.+-- Parameter @entries@ is the number of (3-line) scores to be shown.+showTable :: TimeZone -> Int -> HighScore.ScoreTable -> Int -> Int+          -> [AttrLine]+showTable tz pos table start entries =+  let zipped    = zip [1..] $ HighScore.unTable table+      screenful = take entries . drop (start - 1) $ zipped+      renderScore (pos1, score1) =+        map (if pos1 == pos then textFgToAL Color.BrWhite else textToAL)+        $ HighScore.showScore tz pos1 score1+  in emptyAttrLine : intercalate [emptyAttrLine] (map renderScore screenful)++-- | Produce a couple of renderings of the high scores table.+showNearbyScores :: TimeZone -> Int -> HighScore.ScoreTable -> Int+                 -> [[AttrLine]]+showNearbyScores tz pos h entries =+  if pos <= entries+  then [showTable tz pos h 1 entries]+  else [ showTable tz pos h 1 entries+       , showTable tz pos h (max (entries + 1) (pos - entries `div` 2))+                   entries ]
+ engine-src/Game/LambdaHack/Client/UI/SlideshowM.hs view
@@ -0,0 +1,581 @@+-- | Monadic operations on slideshows and related data.+module Game.LambdaHack.Client.UI.SlideshowM+  ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeepHalt+  , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms+  , displayChoiceScreen+  , displayChoiceScreenWithRightPane+  , displayChoiceScreenWithDefItemKey+  , displayChoiceScreenWithRightPaneKMKM+  , pushFrame, pushReportFrame+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , getMenuIx, saveMenuIx, stepChoiceScreen, navigationKeys, findKYX+  , drawHighlight, basicFrameWithoutReport+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Char as Char+import           Data.Either+import qualified Data.EnumMap.Strict as EM+import qualified Data.Map.Strict as M+import qualified Data.Text as T++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.FrameM+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Definition.Color as Color++-- | Add current report to the overlay, split the result and produce,+-- possibly, many slides.+overlayToSlideshow :: MonadClientUI m+                   => Int -> [K.KM] -> OKX -> m Slideshow+overlayToSlideshow y keys okx = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  UIOptions{uMsgWrapColumn} <- getsSession sUIOptions+  report <- getReportUI True+  recordHistory  -- report will be shown soon, remove it to history+  fontSetup <- getFontSetup+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  let displayTutorialHints = fromMaybe curTutorial overrideTut+  return $! splitOverlay fontSetup displayTutorialHints+                         rwidth y uMsgWrapColumn report keys okx++-- | Split current report into a slideshow.+reportToSlideshow :: MonadClientUI m => [K.KM] -> m Slideshow+reportToSlideshow keys = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  overlayToSlideshow (rheight - 2) keys emptyOKX++-- | Split current report into a slideshow. Keep report unchanged.+-- Assume the game either halts waiting for a key after this is shown,+-- or many slides are produced, all but the last are displayed+-- with player promts between and the last is either shown+-- in full or ignored if inside macro (can be recovered from history,+-- if important). Unless the prompts interrupt the macro, which is as well.+reportToSlideshowKeepHalt :: MonadClientUI m => Bool -> [K.KM] -> m Slideshow+reportToSlideshowKeepHalt insideMenu keys = do+  CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+  UIOptions{uMsgWrapColumn} <- getsSession sUIOptions+  report <- getReportUI insideMenu+  -- Don't do @recordHistory@; the message is important, but related+  -- to the messages that come after, so should be shown together.+  fontSetup <- getFontSetup+  curTutorial <- getsSession scurTutorial+  overrideTut <- getsSession soverrideTut+  let displayTutorialHints = fromMaybe curTutorial overrideTut+  return $! splitOverlay fontSetup displayTutorialHints+                         rwidth (rheight - 2) uMsgWrapColumn+                         report keys emptyOKX++-- | Display a message. Return value indicates if the player wants to continue.+-- Feature: if many pages, only the last SPACE exits (but first ESC).+displaySpaceEsc :: MonadClientUI m => ColorMode -> Text -> m Bool+displaySpaceEsc dm prompt = do+  unless (T.null prompt) $ msgLnAdd MsgPromptGeneric prompt+  -- Two frames drawn total (unless @prompt@ very long).+  slides <- reportToSlideshow [K.spaceKM, K.escKM]+  km <- getConfirms dm [K.spaceKM, K.escKM] slides+  return $! km == K.spaceKM++-- | Display a message. Ignore keypresses.+-- Feature: if many pages, only the last SPACE exits (but first ESC).+displayMore :: MonadClientUI m => ColorMode -> Text -> m ()+displayMore dm prompt = do+  unless (T.null prompt) $ msgLnAdd MsgPromptGeneric prompt+  slides <- reportToSlideshow [K.spaceKM]+  void $ getConfirms dm [K.spaceKM, K.escKM] slides++displayMoreKeep :: MonadClientUI m => ColorMode -> Text -> m ()+displayMoreKeep dm prompt = do+  unless (T.null prompt) $ msgLnAdd MsgPromptGeneric prompt+  slides <- reportToSlideshowKeepHalt True [K.spaceKM]+  void $ getConfirms dm [K.spaceKM, K.escKM] slides++-- | 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 -> Text -> m Bool+displayYesNo dm prompt = do+  unless (T.null prompt) $ msgLnAdd MsgPromptGeneric prompt+  let yn = map K.mkChar ['y', 'n']+  slides <- reportToSlideshow yn+  km <- getConfirms dm (K.escKM : yn) slides+  return $! km == K.mkChar 'y'++getConfirms :: MonadClientUI m+            => ColorMode -> [K.KM] -> Slideshow -> m K.KM+getConfirms dm extraKeys slides = do+  ekm <- displayChoiceScreen "" dm False slides extraKeys+  return $! either id (error $ "" `showFailure` ekm) ekm++-- | Display a, potentially, multi-screen menu and return the chosen+-- key or menu slot (and save the index in the whole menu so that the cursor+-- can again be placed at that spot next time menu is displayed).+--+-- This function is one of only two sources of menus and so,+-- effectively, UI modes.+displayChoiceScreen :: forall m . MonadClientUI m+                    => String -> ColorMode -> Bool -> Slideshow -> [K.KM]+                    -> m KeyOrSlot+displayChoiceScreen = do+  displayChoiceScreenWithRightPane (const $ return emptyOKX) False++-- | Display a, potentially, multi-screen menu and return the chosen+-- key or menu slot (and save the index in the whole menu so that the cursor+-- can again be placed at that spot next time menu is displayed).+-- Additionally, display something on the right half of the screen,+-- depending on which menu item is currently highlighted+--+-- This function is one of only two sources of menus and so,+-- effectively, UI modes.+displayChoiceScreenWithRightPane+  :: forall m . MonadClientUI m+  => (KeyOrSlot -> m OKX)+  -> Bool -> String -> ColorMode -> Bool -> Slideshow -> [K.KM]+  -> m KeyOrSlot+displayChoiceScreenWithRightPane displayInRightPane+                                 highlightBullet menuName dm sfBlank+                                 frsX extraKeys = do+  kmkm <- displayChoiceScreenWithRightPaneKMKM+                                 displayInRightPane+                                 highlightBullet menuName dm sfBlank+                                 frsX extraKeys+  return $! case kmkm of+    Left (km, _) -> Left km+    Right slot -> Right slot++-- | A specialized variant of 'displayChoiceScreenWithRightPane'.+displayChoiceScreenWithDefItemKey :: MonadClientUI m+                                  => (Int -> MenuSlot -> m OKX)+                                  -> Slideshow+                                  -> [K.KM]+                                  -> String+                                  -> m KeyOrSlot+displayChoiceScreenWithDefItemKey f sli itemKeys menuName = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  FontSetup{propFont} <- getFontSetup+  let g ekm = case ekm of+        Left{} -> return emptyOKX+        Right slot -> do+          if isSquareFont propFont+          then return emptyOKX+          else f (rwidth - 2) slot+  displayChoiceScreenWithRightPane+    g True menuName ColorFull False sli itemKeys++-- | A variant providing for a keypress the information about the label+-- of the menu slot which was selected during the keypress.+displayChoiceScreenWithRightPaneKMKM+  :: forall m . MonadClientUI m+  => (KeyOrSlot -> m OKX)+  -> Bool -> String -> ColorMode -> Bool -> Slideshow -> [K.KM]+  -> m (Either (K.KM, KeyOrSlot) MenuSlot)+displayChoiceScreenWithRightPaneKMKM displayInRightPane+                                     highlightBullet menuName dm sfBlank+                                     frsX extraKeys = do+  (maxIx, initIx, clearIx, m)+    <- stepChoiceScreen highlightBullet dm sfBlank frsX extraKeys+  let loop :: Int -> KeyOrSlot -> m (Either (K.KM, KeyOrSlot) MenuSlot, Int)+      loop pointer km = do+        okxRight <- displayInRightPane km+        (final, kmkm1, pointer1) <- m pointer okxRight+        if final+        then return (kmkm1, pointer1)+        else loop pointer1 $ case kmkm1 of+          Left (km1, _) -> Left km1+          Right slot -> Right slot+  pointer0 <- getMenuIx menuName maxIx initIx clearIx+  let km0 = case findKYX pointer0 $ slideshow frsX of+        Nothing -> error $ "no menu keys" `showFailure` frsX+        Just (_, (ekm, _), _) -> ekm+  (km, pointer) <- loop pointer0 km0+  saveMenuIx menuName initIx pointer+  return km++getMenuIx :: MonadClientUI m => String -> Int -> Int -> Int -> m Int+getMenuIx menuName maxIx initIx clearIx = do+  menuIxMap <- getsSession smenuIxMap+  -- Beware, values in @menuIxMap@ may be negative (meaning: a key, not slot).+  let menuIx = if menuName == ""+               then clearIx+               else maybe clearIx (+ initIx) (M.lookup menuName menuIxMap)+                      -- this may still be negative, from different context+  return $! max clearIx $ min maxIx menuIx  -- so clamp to point at item, not key++saveMenuIx :: MonadClientUI m => String -> Int -> Int -> m ()+saveMenuIx menuName initIx pointer =+  unless (menuName == "") $+    modifySession $ \sess ->+      sess {smenuIxMap = M.insert menuName (pointer - initIx) $ smenuIxMap sess}++-- | This is one step of UI menu management user session.+--+-- There is limited looping involved to return a changed position+-- in the menu each time so that the surrounding code has anything+-- interesting to do. The exception is when finally confirming a selection,+-- in which case it's usually not changed compared to last step,+-- but it's presented differently to indicate it was confirmed.+--+-- Any extra keys in the `OKX` argument on top of the those in @Slideshow@+-- argument need to be contained in the @[K.KM]@ argument. Otherwise+-- they are not accepted.+stepChoiceScreen :: forall m . MonadClientUI m+                 => Bool -> ColorMode -> Bool -> Slideshow -> [K.KM]+                 -> m ( Int, Int, Int+                      , Int -> OKX+                        -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int) )+stepChoiceScreen highlightBullet dm sfBlank frsX extraKeys = do+  CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui+  FontSetup{..} <- getFontSetup+  UIOptions{uVi, uLeftHand} <- getsSession sUIOptions+  let !_A = assert (K.escKM `elem` extraKeys) ()+      frs = slideshow frsX+      keys = concatMap (lefts . map fst . snd) frs ++ extraKeys+      cardinalKeys = K.cardinalAllKM uVi uLeftHand+      handleDir = K.handleCardinal cardinalKeys+      legalKeys = keys ++ navigationKeys ++ cardinalKeys+      allOKX = concatMap snd frs+      maxIx = length allOKX - 1+      initIx = case findIndex (isRight . fst) allOKX of+        Just p -> p+        _ -> 0  -- can't be @length allOKX@ or a multi-page item menu+                -- mangles saved index of other item munus+      clearIx = if initIx > maxIx then 0 else initIx+      canvasLength = if sfBlank then rheight else rheight - 2+      trimmedY = canvasLength - 1 - 2  -- will be translated down 2 lines+      trimmedAlert = ( PointUI 0 trimmedY+                     , stringToAL "--a portion of the text trimmed--" )+      page :: Int -> OKX -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int)+      page pointer (ovsRight0, kyxsRight) = assert (pointer >= 0)+                                            $ case findKYX pointer frs of+        Nothing -> error $ "no menu keys" `showFailure` frs+        Just ( (ovs0, kyxs2)+             , (ekm, (PointUI x1 y, buttonWidth))+             , ixOnPage ) -> do+          let ovs1 = EM.map (updateLine y $ drawHighlight x1 buttonWidth) ovs0+              ovs2 = if highlightBullet+                     then EM.map (highBullet kyxs2) ovs1+                     else ovs1+              -- We add spaces in proportional font under the report rendered+              -- in mono font and the right pane text in prop font,+              -- but over menu lines in proportional font that can be+              -- very long an should not peek from under the right pane text.+              --+              -- We translate the pane by two characters right, because it looks+              -- better when a couple last characters of a line vanish+              -- off-screen than when characters touch in the middle+              -- of the screen. The code producing right panes should take care+              -- to generate lines two shorter than usually.+              --+              -- We move the pane two characters down, because normally+              -- reports should not be longer than three lines+              -- and the third no longer than half width.+              -- We also add two to three lines of backdrop at the bottom.+              ymax = maxYofFontOverlayMap ovsRight0+              -- Apparently prop spaces can be really narrow, hence so many.+              -- With square font, this obscures the link in main menu,+              -- so would need to complicated.+              spaceRectangle | isSquareFont propFont = []+                             | otherwise =+                                 rectangleOfSpaces (rwidth * 4)+                                                   (min canvasLength $ ymax + 5)+              trim = filter (\(PointUI _ yRight, _) -> yRight < trimmedY)+              -- The alert not clickable, because the player can enter+              -- the menu entry and scroll through the unabridged blurb.+              ovsRight1 = if ymax <= trimmedY+                          then ovsRight0+                          else EM.unionWith (++)+                                 (EM.map trim ovsRight0)+                                 (EM.singleton monoFont [trimmedAlert])+              ovsRight = EM.unionWith (++)+                           (EM.singleton propFont spaceRectangle)+                           (EM.map (xytranslateOverlay 2 2) ovsRight1)+              (ovs, kyxs) =+                if EM.null ovsRight0+                then (ovs2, kyxs2)+                else sideBySideOKX rwidth 0 (ovs2, kyxs2) (ovsRight, kyxsRight)+              kmkm ekm2 = case ekm2 of+                Left km -> Left (km, ekm2)+                Right slot -> Right slot+              tmpResult pointer1 = case findKYX pointer1 frs of+                Nothing -> error $ "no menu keys" `showFailure` frs+                Just (_, (ekm1, _), _) -> return (False, kmkm ekm1, pointer1)+              ignoreKey = return (False, kmkm ekm, pointer)+              pageLen = length kyxs+              xix :: KYX -> Bool+              xix (_, (PointUI x1' _, _)) = x1' <= x1 + 2 && x1' >= x1 - 2+              firstRowOfNextPage = pointer + pageLen - ixOnPage+              restOKX = drop firstRowOfNextPage allOKX+              -- This does not take into account the right pane, which is fine.+              firstItemOfNextPage = case findIndex (isRight . fst) restOKX of+                Just p -> p + firstRowOfNextPage+                _ -> firstRowOfNextPage+              interpretKey :: K.KM+                           -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int)+              interpretKey ikm =+                case K.key ikm of+                  _ | ikm == K.controlP -> do+                    -- Silent, because any prompt would be shown too late.+                    printScreen+                    ignoreKey+                  K.Return -> case ekm of+                    Left km ->+                      if K.key km == K.Return+                      then return (True, Left (km, ekm), pointer)+                      else interpretKey km+                    Right c -> return (True, Right c, pointer)+                  K.LeftButtonRelease -> do+                    PointUI mx my <- getsSession spointer+                    let onChoice (_, (PointUI cx cy, ButtonWidth font clen)) =+                          let blen | isSquareFont font = 2 * clen+                                   | otherwise = clen+                          in my == cy && mx >= cx && mx < cx + blen+                    case find onChoice kyxs of+                      Nothing | ikm `elem` keys ->+                        return (True, Left (ikm, ekm), pointer)+                      Nothing ->+                        if K.spaceKM `elem` keys+                        then return (True, Left (K.spaceKM, ekm), pointer)+                        else ignoreKey+                      Just (ckm, _) -> case ckm of+                        Left km ->+                          if K.key km == K.Return && km `elem` keys+                          then return (True, Left (km, ekm), pointer)+                          else interpretKey km+                        Right c  -> return (True, Right c, pointer)+                  K.RightButtonRelease ->+                    if ikm `elem` keys+                    then return (True, Left (ikm, ekm), pointer)+                    else return (True, Left (K.escKM, ekm), pointer)+                  K.Space | firstItemOfNextPage <= maxIx ->+                    tmpResult firstItemOfNextPage+                  K.Unknown "SAFE_SPACE" ->+                    if firstItemOfNextPage <= maxIx+                    then tmpResult firstItemOfNextPage+                    else tmpResult clearIx+                  _ | ikm `elem` keys ->+                    return (True, Left (ikm, ekm), pointer)+                  _ | K.key ikm == K.WheelNorth+                      || handleDir ikm == Just (Vector 0 (-1)) ->+                    case findIndex xix $ reverse $ take ixOnPage kyxs of+                      Nothing -> if pointer == 0 then tmpResult maxIx+                                 else tmpResult (max 0 (pointer - 1))+                      Just ix -> tmpResult (max 0 (pointer - ix - 1))+                  _ | K.key ikm == K.WheelSouth+                      || handleDir ikm == Just (Vector 0 1) ->+                    case findIndex xix $ drop (ixOnPage + 1) kyxs of+                      Nothing -> if pointer == maxIx then tmpResult 0+                                 else tmpResult (min maxIx (pointer + 1))+                      Just ix -> tmpResult (pointer + ix + 1)+                  _ | handleDir ikm == Just (Vector (-1) 0) ->+                    case findKYX (max 0 (pointer - 1)) frs of+                      Just (_, (_, (PointUI _ y2, _)), _) | y2 == y ->+                        tmpResult (max 0 (pointer - 1))+                      _ -> ignoreKey+                  _ | handleDir ikm == Just (Vector 1 0) ->+                    case findKYX (min maxIx (pointer + 1)) frs of+                      Just (_, (_, (PointUI _ y2, _)), _) | y2 == y ->+                        tmpResult (min maxIx (pointer + 1))+                      _ -> ignoreKey+                  K.Home -> tmpResult clearIx+                  K.End -> tmpResult maxIx+                  K.PgUp ->+                    tmpResult (max 0 (pointer - ixOnPage - 1))+                  K.PgDn ->+                    -- This doesn't scroll by screenful when header very long+                    -- and menu non-empty, but that scenario is rare, so OK,+                    -- arrow keys may be used instead.+                    tmpResult (min maxIx firstItemOfNextPage)+                  K.Space -> ignoreKey+                  _ | K.key ikm `elem` [K.Char '?', K.Fun 1] -> do+                    -- Clear macros and invoke the help macro.+                    modifySession $ \sess ->+                      sess { smacroFrame =+                               emptyMacroFrame {keyPending =+                                                  KeyMacro [K.mkKM "F1"]}+                           , smacroStack = [] }+                    return (True, Left (K.escKM, ekm), pointer)+                  _ -> error $ "unknown key" `showFailure` ikm+          pkm <- promptGetKey dm ovs sfBlank legalKeys+          interpretKey pkm+      m pointer okxRight =+        if null frs+        then return (True, Left (K.escKM, Left K.escKM), pointer)+        else do+          (final, km, pointer1) <- page pointer okxRight+          let !_A1 = assert (either ((`elem` keys) . fst) (const True) km) ()+          -- Pointer at a button included, hence greater than 0, not @clearIx@.+          let !_A2 = assert (0 <= pointer1 && pointer1 <= maxIx+                             `blame`  (pointer1, maxIx)) ()+          return (final, km, pointer1)+  return (maxIx, initIx, clearIx, m)++navigationKeys :: [K.KM]+navigationKeys = [ K.leftButtonReleaseKM, K.rightButtonReleaseKM+                 , K.returnKM, K.spaceKM, K.wheelNorthKM, K.wheelSouthKM+                 , K.pgupKM, K.pgdnKM, K.homeKM, K.endKM, K.controlP+                 , K.mkChar '?', K.mkKM "F1" ]++-- | Find a position in a menu.+-- The arguments go from first menu line and menu page to the last,+-- in order. Their indexing is from 0. We select the nearest item+-- with the index equal or less to the pointer.+findKYX :: Int -> [OKX] -> Maybe (OKX, KYX, Int)+findKYX _ [] = Nothing+findKYX pointer (okx@(_, kyxs) : frs2) =+  case drop pointer kyxs of+    [] ->  -- not enough menu items on this page+      case findKYX (pointer - length kyxs) frs2 of+        Nothing ->  -- no more menu items in later pages+          case reverse kyxs of+            [] -> Nothing+            kyx : _ -> Just (okx, kyx, length kyxs - 1)+        res -> res+    kyx : _ -> Just (okx, kyx, pointer)++drawHighlight :: Int -> ButtonWidth -> Int -> AttrString -> AttrString+drawHighlight x1 (ButtonWidth font len) xstart as =+  let highableAttrs = [Color.defAttr, Color.defAttr {Color.fg = Color.BrBlack}]+      highAttr c | Color.acAttr c `notElem` highableAttrs+                   || Color.acChar c == ' ' = c+      highAttr c = c {Color.acAttr =+                        (Color.acAttr c) {Color.fg = Color.BrWhite}}+      cursorAttr c = c {Color.acAttr =+                          (Color.acAttr c)+                             {Color.bg = Color.HighlightNoneCursor}}+      noCursorAttr c = c {Color.acAttr =+                            (Color.acAttr c)+                               {Color.bg = Color.HighlightNone}}+      -- This also highlights dull white item symbols, but who cares.+      lenUI = if isSquareFont font then len * 2 else len+      x1MinusXStartChars = if isSquareFont font+                           then (x1 - xstart) `div` 2+                           else x1 - xstart+      (as1, asRest) = splitAt x1MinusXStartChars as+      (as2, as3) = splitAt len asRest+      highW32 = Color.attrCharToW32 . highAttr . Color.attrCharFromW32+      as2High = map highW32 as2+      cursorW32 = Color.attrCharToW32 . cursorAttr . Color.attrCharFromW32+      (nonAlpha, alpha) = break (Char.isAlphaNum . Color.charFromW32) as2High+      as2Cursor = case alpha of+        [] -> []+        ch : chrest -> cursorW32 ch : chrest+      noCursorW32 = Color.attrCharToW32 . noCursorAttr . Color.attrCharFromW32+  in if x1 + lenUI < xstart+     then as+     else as1 ++ map noCursorW32 nonAlpha ++ as2Cursor ++ as3++drawBullet :: Int -> ButtonWidth -> Int -> AttrString -> AttrString+drawBullet x1 (ButtonWidth font len) xstart as0 =+  let diminishChar '-' = ' '+      diminishChar '^' = '^'+      diminishChar '"' = '"'+      diminishChar _ = '·'+      highableAttr = Color.defAttr {Color.bg = Color.HighlightNoneCursor}+      highW32 ac32 =+        let ac = Color.attrCharFromW32 ac32+            ch = diminishChar $ Color.acChar ac+        in if | Color.acAttr ac /= highableAttr -> ac32+              | Color.acChar ac == ' ' ->+                  error $ "drawBullet: HighlightNoneCursor space forbidden"+                          `showFailure` (ac, map Color.charFromW32 as0)+              | ch == ' ' -> Color.spaceAttrW32+              | otherwise ->+                  Color.attrCharToW32+                  $ ac { Color.acAttr = Color.defAttr {Color.fg = Color.BrBlack}+                       , Color.acChar = ch }+      lenUI = if isSquareFont font then len * 2 else len+      x1MinusXStartChars = if isSquareFont font+                           then (x1 - xstart) `div` 2+                           else x1 - xstart+      (as1, asRest) = splitAt x1MinusXStartChars as0+      (as2, as3) = splitAt len asRest+      highAs = \case+        toHighlight : rest -> highW32 toHighlight : rest+        [] -> []+  in if x1 + lenUI < xstart+     then as0+     else as1 ++ highAs as2 ++ as3++highBullet :: [KYX] -> Overlay -> Overlay+highBullet kyxs ov0 =+  let f (_, (PointUI x1 y, buttonWidth)) =+        updateLine y $ drawBullet x1 buttonWidth+  in foldr f ov0 kyxs++-- This is not our turn, so we can't obstruct screen with messages+-- and message reformatting causes distraction, so there's no point+-- trying to squeeze the report into the single available line,+-- except when it's not our turn permanently, because AI runs UI.+--+-- The only real drawback of this is that when resting for longer time+-- I can't see the boring messages accumulate until a non-boring interrupts me.+basicFrameWithoutReport :: MonadClientUI m+                        => LevelId -> Maybe Bool -> m PreFrame3+basicFrameWithoutReport arena forceReport = do+  FontSetup{propFont} <- getFontSetup+  sbenchMessages <- getsClient $ sbenchMessages . soptions+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  truncRep <-+    if | sbenchMessages -> do+         slides <- reportToSlideshowKeepHalt False []+         case slideshow slides of+           [] -> return EM.empty+           (ov, _) : _ -> do+             -- See @stepQueryUI@. This strips either "--end-" or "--more-".+             let ovProp = ov EM.! propFont+             return $!+               EM.singleton propFont+               $ if EM.size ov > 1 then ovProp else init ovProp+       | fromMaybe (gunderAI fact) forceReport -> do+         report <- getReportUI False+         let par1 = firstParagraph $ foldr (<+:>) [] $ renderReport True report+         return $! EM.fromList [(propFont, [(PointUI 0 0, par1)])]+       | otherwise -> return EM.empty+  drawOverlay ColorFull False truncRep arena++-- | Push the frame depicting the current level to the frame queue.+-- Only one line of the report is shown, as in animations,+-- because it may not be our turn, so we can't clear the message+-- to see what is underneath.+pushFrame :: MonadClientUI m => Bool -> m ()+pushFrame delay = do+  -- The delay before reaction to keypress was too long in case of many+  -- projectiles flying and ending flight, so frames need to be skipped.+  keyPressed <- anyKeyPressed+  unless keyPressed $ do+    lidV <- viewedLevelUI+    frame <- basicFrameWithoutReport lidV Nothing+    -- Pad with delay before and after to let player see, e.g., door being+    -- opened a few ticks after it came into vision, the same turn.+    displayFrames lidV $+      if delay then [Nothing, Just frame, Nothing] else [Just frame]++pushReportFrame :: MonadClientUI m => m ()+pushReportFrame = do+  lidV <- viewedLevelUI+  frame <- basicFrameWithoutReport lidV (Just True)+  displayFrames lidV [Just frame]
+ engine-src/Game/LambdaHack/Client/UI/TutorialHints.hs view
@@ -0,0 +1,65 @@+module Game.LambdaHack.Client.UI.TutorialHints+  ( TutorialHints (..)+  , renderTutorialHints+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++data TutorialHints =+    DamageOfDifferentKind+  | NewFloorNewOpportunity+  | CannotHarmYouInMelee+  | CaughtProjectile+  | HitsWithNoDirectDamage+  | TemporaryConditions+  | WokenUpActors+  | AvoidWalkingEnemies+  | AlotOfDamageFromOneSource+  | TerrainNotFullyKnown+  | OutOfSightEvents+  | HearingRadius+  | SwitchTeammate+  | MeleeEnemies+  | UseTerrainEffect+  | SwitchPointmanAndAvoidMeleeAlone+  | SwitchPointmanAndSoftenFoes++-- | Generate the standard textual representation for the tutorial hints.+renderTutorialHints :: TutorialHints -> Text+renderTutorialHints = \case+  DamageOfDifferentKind ->+    "You took damage of a different kind than the normal piercing hit, which means your armor couldn't block any part of it. Normally, your HP (hit points, health) do not regenerate, so losing them is a big deal. Apply healing concoctions or take a long sleep to replenish your HP (but in this hectic environment not even uninterrupted resting that leads to sleep is easy)."+  NewFloorNewOpportunity ->+    "New floor is new opportunities, though the old level is still there and others may roam it after you left. Viewing all floors, without moving between them, can be done using the '<' and '>' keys."+  CannotHarmYouInMelee ->+    "This enemy can't harm you in melee. Left alone could it possibly be of some use?"+  CaughtProjectile ->+    "You managed to catch a projectile, thanks to being braced and hitting it exactly when it was at arm's reach. The obtained item has been put into the shared stash of your party."+  HitsWithNoDirectDamage ->+    "Some hits don't cause piercing, impact, burning nor any other direct damage. However, they can have other effects, bad, good or both."+  WokenUpActors ->+    "Woken up actors regain stats and skills, including sight radius and melee armor, over several turns."+  AvoidWalkingEnemies ->+    "To avoid waking enemies up, make sure they don't lose HP nor too much Calm through noises, particularly close ones. Beware, however, that they slowly regenerate HP as they sleep and eventually wake up at full HP."+  AlotOfDamageFromOneSource ->+    "You took a lot of damage from one source. If the danger persists, consider retreating towards your teammates or buffing up or an instant escape, if consumables permit."+  TemporaryConditions ->+    "Temporary conditions, especially the bad ones, pass quickly, usually after just a few turns. While active, they are listed in the '@' organ menu and the effects of most of them are seen in the '#' skill menu."+  TerrainNotFullyKnown ->+    "Solid terrain drawn in pink is not fully known until searched. This is usually done by bumping into it, which also triggers effects and transformations the terrain is capable of. Once revealed, the terrain can be inspected in aiming mode started with the '*' key or with mouse."+  OutOfSightEvents ->+    "Events out of your sight radius (as listed in the '#' skill menu) can sometimes be heard, depending on your hearing radius skill. Some, such as death shrieks, can always be heard regardless of skill and distance, including when they come from a different floor."+  HearingRadius ->+    "Enemies you can't see are sometimes heard yelling and emitting other noises. Whether you can hear them, depends on their distance and your hearing radius, as listed in the '#' skill menu."+  SwitchTeammate ->+    "You survive this mission, or die trying, as a team. After a few moves, feel free to switch the controlled teammate (marked on the map with the yellow box) using the Tab key to another party member (marked with a green box)."  -- assuming newbies don't remap their keys+  MeleeEnemies ->+    "Enemies are normally dealt with using melee (by bumping when adjacent) or ranged combat (by 'f'linging items at them)."+  UseTerrainEffect ->+    "Enemies can be dealt with not only via combat, but also with clever use of terrain effects, stealth (not emitting nor reflecting light) or hasty retreat (particularly when foes are asleep or drowsy)."+  SwitchPointmanAndAvoidMeleeAlone ->+    "When dealing with groups of enemies, remember than you fight as a team. Switch the pointman (marked on the map with the yellow box) using the Tab key until you move each teammate to a tactically advantageous position. Avoid meleeing alone."+  SwitchPointmanAndSoftenFoes ->+    "When dealing with groups of armed enemies, remember than you fight as a team. Switch the pointman (marked on the map with the yellow box) using the Tab key until you move each teammate to a tactically advantageous position. Retreat, if necessary to form a front line. Soften the foes with missiles, especially of exploding kind."
+ engine-src/Game/LambdaHack/Client/UI/UIOptions.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveGeneric #-}+-- | UI client options specified in the config file.+module Game.LambdaHack.Client.UI.UIOptions+  ( UIOptions(..)+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Control.DeepSeq+import Data.Binary+import GHC.Generics (Generic)++import           Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Common.ClientOptions (FullscreenMode)+import           Game.LambdaHack.Common.Misc+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs++-- | Options that affect the UI of the client, specified in the config file.+-- More documentation is in the default config file.+data UIOptions = UIOptions+  { uCommands         :: [(K.KM, CmdTriple)]+  , uHeroNames        :: [(Int, (Text, Text))]+  , uVi               :: Bool+  , uLeftHand         :: Bool+  , uChosenFontset    :: Text+  , uAllFontsScale    :: Double+  , uFullscreenMode   :: FullscreenMode+  , uhpWarningPercent :: Int+  , uMsgWrapColumn    :: X+  , uHistoryMax       :: Int+  , uMaxFps           :: Double+  , uNoAnim           :: Bool+  , uOverrideCmdline  :: [String]+  , uFonts            :: [(Text, FontDefinition)]+  , uFontsets         :: [(Text, FontSet)]+  , uMessageColors    :: [(String, Color.Color)]+  }+  deriving (Show, Generic)++instance NFData UIOptions++instance Binary UIOptions
+ engine-src/Game/LambdaHack/Client/UI/UIOptionsParse.hs view
@@ -0,0 +1,175 @@+-- | UI client options.+module Game.LambdaHack.Client.UI.UIOptionsParse+  ( mkUIOptions, applyUIOptions+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , configError, readError, parseConfig+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.DeepSeq+import qualified Data.Ini as Ini+import qualified Data.Ini.Reader as Ini+import qualified Data.Ini.Types as Ini+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import           Data.Version+import           System.FilePath+import           Text.ParserCombinators.ReadP (readP_to_S)+import           Text.Read++import           Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.File+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Save (compatibleVersion, delayPrint)+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Content.RuleKind++configError :: String -> a+configError err = error $ "Error when parsing configuration file. Please fix config.ui.ini or remove it altogether. The details:\n" ++ err++readError :: Read a => String -> a+readError s = either (configError . ("when reading:\n" ++ s `showFailure`)) id+              $ readEither s++parseConfig :: Ini.Config -> UIOptions+parseConfig cfg =+  let uCommands =+        let mkCommand (ident, keydef) =+              case stripPrefix "Cmd_" ident of+                Just _ ->+                  let (key, def) = readError keydef+                  in (K.mkKM key, def :: CmdTriple)+                Nothing ->+                  configError+                    $ "macro id should start with Cmd_ and it does not:"+                      `showFailure` ident+            section = Ini.allItems "additional_commands" cfg+        in map mkCommand section+      uHeroNames =+        let toNumber (ident, nameAndPronoun) =+              case stripPrefix "HeroName_" ident of+                Just n -> (readError n, readError nameAndPronoun)+                Nothing -> configError+                           $ "wrong hero name id" `showFailure` ident+            section = Ini.allItems "hero_names" cfg+        in map toNumber section+      lookupFail :: forall b. String -> String -> b+      lookupFail optionName err =+        configError $ "config file access failed"+                      `showFailure` (err, optionName, cfg)+      _getOptionMaybe :: forall a. Read a => String -> Maybe a+      _getOptionMaybe optionName =+        let ms = Ini.getOption "ui" optionName cfg+        in either (lookupFail optionName) id . readEither <$> ms+      getOption :: forall a. Read a => String -> a+      getOption optionName =+        let s = fromMaybe (lookupFail optionName "")+                $ Ini.getOption "ui" optionName cfg+        in either (lookupFail optionName) id $ readEither s+      uVi = getOption "movementViKeys_hjklyubn"+      uLeftHand = getOption "movementLeftHandKeys_axwdqezc"+      uChosenFontset = getOption "chosenFontset"+      uAllFontsScale = getOption "allFontsScale"+      uFullscreenMode = getOption "fullscreenMode"+      uhpWarningPercent = getOption "hpWarningPercent"+      uMsgWrapColumn = getOption "msgWrapColumn"+      uHistoryMax = getOption "historyMax"+      uMaxFps = max 1 $ getOption "maxFps"+      uNoAnim = getOption "noAnim"+      uOverrideCmdline = glueSeed $ words $ getOption "overrideCmdline"+      uFonts =+        let toFont (ident, fontString) = (T.pack ident, readError fontString)+            section = Ini.allItems "fonts" cfg+        in map toFont section+      uFontsets =+        let toFontSet (ident, fontSetString) =+              (T.pack ident, readError fontSetString)+            section = Ini.allItems "fontsets" cfg+        in map toFontSet section+      uMessageColors =+        map (second readError) $ Ini.allItems "message_colors" cfg+  in UIOptions{..}++glueSeed :: [String] -> [String]+glueSeed [] = []+glueSeed ("SMGen" : s1 : s2 : rest) =+  ("SMGen" ++ " " ++ s1 ++ " " ++ s2) : glueSeed rest+glueSeed (s : rest) = s : glueSeed rest++-- | Read and parse UI config file.+mkUIOptions :: RuleContent -> ClientOptions -> IO UIOptions+mkUIOptions corule clientOptions = do+  let benchmark = sbenchmark clientOptions+      cfgUIName = rcfgUIName corule+      (configText, cfgUIDefault) = rcfgUIDefault corule+  dataDir <- appDataDir+  let path bkp = dataDir </> bkp <> cfgUIName+  cfgUser <- if benchmark then return Ini.emptyConfig else do+    cpExists <- doesFileExist (path "")+    if not cpExists+      then return Ini.emptyConfig+      else do+        sUser <- readFile (path "")+        return $! either (configError . ("Ini.parse sUser" `showFailure`)) id+                  $ Ini.parse sUser+  let cfgUI = M.unionWith M.union cfgUser cfgUIDefault  -- user cfg preferred+      vExe1 = rexeVersion corule+      vExe2 =+        let optionName = "version"+            -- Lenient to parse, and reject, old config files:+            s = fromMaybe "" $ Ini.getOption "version" optionName cfgUser+            dummyVersion = makeVersion []+        in case find ((== "") . snd) $ readP_to_S parseVersion s of+          Just (ver, "") -> ver+          _ -> dummyVersion+  if benchmark || compatibleVersion vExe1 vExe2 then do+    let conf = parseConfig cfgUI+    -- Catch syntax errors in complex expressions ASAP.+    return $! deepseq conf conf+  else do+    cpExists <- doesFileExist (path "")+    when cpExists $ do+      renameFile (path "") (path "bkp.")+      moveAside <- Save.bkpAllSaves corule clientOptions+      let msg = "Config file" <+> T.pack (path "")+                <+> "from an incompatible version '"+                <> T.pack (showVersion vExe2)+                <> "' detected while starting"+                <+> T.pack (showVersion vExe1)+                <+> "game."+                <+> if moveAside+                    then "The config file and savefiles have been moved aside."+                    else "The config file has been moved aside."+      delayPrint msg+    dataDirExists <- doesFileExist dataDir+    when dataDirExists $  -- may not exist, e.g., when testing+      tryWriteFile (path "") configText+    let confDefault = parseConfig cfgUIDefault+    return confDefault++-- | Modify client options with UI options.+applyUIOptions :: COps -> UIOptions -> ClientOptions -> ClientOptions+applyUIOptions COps{corule} uioptions =+     (\opts -> opts {schosenFontset =+        schosenFontset opts `mplus` Just (uChosenFontset uioptions)}) .+     (\opts -> opts {sallFontsScale =+        sallFontsScale opts `mplus` Just (uAllFontsScale uioptions)}) .+     (\opts -> opts {sfullscreenMode =+        sfullscreenMode opts `mplus` Just (uFullscreenMode uioptions)}) .+     (\opts -> opts {smaxFps =+        smaxFps opts `mplus` Just (uMaxFps uioptions)}) .+     (\opts -> opts {snoAnim =+        snoAnim opts `mplus` Just (uNoAnim uioptions)}) .+     (\opts -> opts {stitle =+        stitle opts `mplus` Just (rtitle corule)}) .+     (\opts -> opts {sfonts = uFonts uioptions}) .+     (\opts -> opts {sfontsets = uFontsets uioptions})
+ engine-src/Game/LambdaHack/Client/UI/Watch.hs view
@@ -0,0 +1,9 @@+-- | Display atomic commands received by the client.+module Game.LambdaHack.Client.UI.Watch+  ( watchRespUpdAtomicUI, watchRespSfxAtomicUI+  ) where++import Prelude ()++import Game.LambdaHack.Client.UI.Watch.WatchSfxAtomicM+import Game.LambdaHack.Client.UI.Watch.WatchUpdAtomicM
+ engine-src/Game/LambdaHack/Client/UI/Watch/WatchCommonM.hs view
@@ -0,0 +1,238 @@+-- | Common code for displaying atomic update and SFX commands.+module Game.LambdaHack.Client.UI.Watch.WatchCommonM+  ( fadeOutOrIn, markDisplayNeeded, lookAtMove, stopAtMove+  , aidVerbMU, aidVerbDuplicateMU, itemVerbMUGeneral, itemVerbMU+  , itemVerbMUShort, itemAidVerbMU, mitemAidVerbMU, itemAidDistinctMU+  , manyItemsAidVerbMU+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.Animation+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.ItemDescription+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Definition.Ability as Ability++fadeOutOrIn :: MonadClientUI m => Bool -> m ()+fadeOutOrIn out = do+  arena <- getArenaUI+  CCUI{coscreen} <- getsSession sccui+  animMap <- rndToActionUI $ fadeout coscreen out 2+  animFrs <- renderAnimFrames arena animMap (Just False)+  displayFrames arena (tail animFrs)  -- no basic frame between fadeout and in++markDisplayNeeded :: MonadClientUI m => LevelId -> m ()+markDisplayNeeded lid = do+  lidV <- viewedLevelUI+  when (lidV == lid) $ modifySession $ \sess -> sess {sdisplayNeeded = True}++lookAtMove :: MonadClientUI m => ActorId -> m ()+lookAtMove aid = do+  mleader <- getsClient sleader+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  aimMode <- getsSession saimMode+  when (not (bproj body)+        && bfid body == side+        && isNothing aimMode) $ do  -- aiming does a more extensive look+    stashBlurb <- lookAtStash (bpos body) (blid body)+    (itemsBlurb, _) <-+      lookAtItems True (bpos body) (blid body) (Just aid) Nothing+    let msgClass = if Just aid == mleader+                   then MsgAtFeetMajor+                   else MsgAtFeetMinor+        blurb = stashBlurb <+> itemsBlurb+    unless (T.null blurb) $+      msgAdd msgClass blurb++stopAtMove :: MonadClientUI m => ActorId -> m ()+stopAtMove aid = do+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  fact <- getsState $ (EM.! bfid body) . sfactionD+  adjBigAssocs <- getsState $ adjacentBigAssocs body+  adjProjAssocs <- getsState $ adjacentProjAssocs body+  if not (bproj body) && bfid body == side then do+    let foe (_, b2) = isFoe (bfid body) fact (bfid b2)+        adjFoes = filter foe $ adjBigAssocs ++ adjProjAssocs+    unless (null adjFoes) stopPlayBack+  else when (isFoe (bfid body) fact side) $ do+    let our (_, b2) = bfid b2 == side+        adjOur = filter our adjBigAssocs+    unless (null adjOur) stopPlayBack++aidVerbMU :: (MonadClientUI m, MsgShared a) => a -> ActorId -> MU.Part -> m ()+aidVerbMU msgClass aid verb = do+  subject <- partActorLeader aid+  msgAdd msgClass $ makeSentence [MU.SubjectVerbSg subject verb]++aidVerbDuplicateMU :: (MonadClientUI m, MsgShared a)+                   => a -> ActorId -> MU.Part -> m Bool+aidVerbDuplicateMU msgClass aid verb = do+  subject <- partActorLeader aid+  msgAddDuplicate msgClass (makeSentence [MU.SubjectVerbSg subject verb])++itemVerbMUGeneral :: MonadClientUI m+                  => Bool -> ItemId -> ItemQuant -> MU.Part -> Container+                  -> m Text+itemVerbMUGeneral verbose iid kit@(k, _) verb c = assert (k > 0) $ do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  lid <- getsState $ lidFromC c+  localTime <- getsState $ getLocalTime lid+  itemFull <- getsState $ itemToFull iid+  side <- getsClient sside+  factionD <- getsState sfactionD+  let arItem = aspectRecordFull itemFull+      partItemWsChosen | verbose = partItemWs+                       | otherwise = partItemWsShort+      subject = partItemWsChosen rwidth side factionD k localTime itemFull kit+      msg | k > 1 && not (IA.checkFlag Ability.Condition arItem) =+              makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]+          | otherwise = makeSentence [MU.SubjectVerbSg subject verb]+  return $! msg++itemVerbMU :: (MonadClientUI m, MsgShared a)+           => a -> ItemId -> ItemQuant -> MU.Part -> Container -> m ()+itemVerbMU msgClass iid kit verb c = do+  msg <- itemVerbMUGeneral True iid kit verb c+  msgAdd msgClass msg++itemVerbMUShort :: (MonadClientUI m, MsgShared a)+                => a -> ItemId -> ItemQuant -> MU.Part -> Container+                -> m ()+itemVerbMUShort msgClass iid kit verb c = do+  msg <- itemVerbMUGeneral False iid kit verb c+  msgAdd msgClass msg++itemAidVerbMU :: (MonadClientUI m, MsgShared a)+              => a -> ActorId -> MU.Part -> ItemId -> Either Int Int+              -> m ()+itemAidVerbMU msgClass aid verb iid ek = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  factionD <- getsState sfactionD+  let lid = blid body+      fakeKit = quantSingle+  localTime <- getsState $ getLocalTime lid+  subject <- partActorLeader aid+  -- The item may no longer be in @c@, but it was.+  itemFull <- getsState $ itemToFull iid+  let object = case ek of+        Left n ->+          partItemWs rwidth side factionD n localTime itemFull fakeKit+        Right n ->+          let (name1, powers) =+                partItemShort rwidth side factionD localTime itemFull fakeKit+          in MU.Phrase ["the", MU.Car1Ws n name1, powers]+      msg = makeSentence [MU.SubjectVerbSg subject verb, object]+  msgAdd msgClass msg++mitemAidVerbMU :: (MonadClientUI m, MsgShared a)+               => a -> ActorId -> MU.Part -> ItemId -> Maybe MU.Part+               -> m ()+mitemAidVerbMU msgClass aid verb iid msuffix = do+  itemD <- getsState sitemD+  case msuffix of+    Just suffix | iid `EM.member` itemD ->+      itemAidVerbMU msgClass aid (MU.Phrase [verb, suffix]) iid (Right 1)+    _ -> do+#ifdef WITH_EXPENSIVE_ASSERTIONS+      side <- getsClient sside+      b <- getsState $ getActorBody aid+      bUI <- getsSession $ getActorUI aid+      -- It's not actually expensive, but it's particularly likely+      -- to fail with wild content, indicating server game rules logic+      -- needs to be fixed/extended.+      -- Observer from another faction may receive the effect information+      -- from the server, because the affected actor is visible,+      -- but the position of the item may be out of FOV. This is fine;+      -- the message is then shorter, because only the effect was seen,+      -- while the cause remains misterious.+      assert (isNothing msuffix  -- item description not requested+              || bfid b /= side  -- not from affected faction; only observing+              `blame` "item never seen by the affected actor"+              `swith` (aid, b, bUI, verb, iid, msuffix)) $+#endif+        aidVerbMU msgClass aid verb++itemAidDistinctMU :: MonadClientUI m+                  => MsgClassDistinct -> ActorId -> MU.Part -> MU.Part -> ItemId+                  -> m ()+itemAidDistinctMU msgClass aid verbShow verbSave iid = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  factionD <- getsState sfactionD+  let lid = blid body+      fakeKit = quantSingle+  localTime <- getsState $ getLocalTime lid+  subject <- partActorLeader aid+  -- The item may no longer be in @c@, but it was.+  itemFull <- getsState $ itemToFull iid+  let object = let (name, powers) =+                     partItem rwidth side factionD localTime itemFull fakeKit+               in MU.Phrase [name, powers]+      t1 = makeSentence [MU.SubjectVerbSg subject verbShow, object]+      t2 = makeSentence [MU.SubjectVerbSg subject verbSave, object]+      dotsIfShorter = if t1 == t2 then "" else ".."+  msgAddDistinct msgClass (t1 <> dotsIfShorter, t2)++manyItemsAidVerbMU :: (MonadClientUI m, MsgShared a)+                   => a -> ActorId -> MU.Part+                   -> [(ItemId, ItemQuant)] -> (Int -> Either (Maybe Int) Int)+                   -> m ()+manyItemsAidVerbMU msgClass aid verb sortedAssocs ekf = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  factionD <- getsState sfactionD+  let lid = blid body+      fakeKit = quantSingle+  localTime <- getsState $ getLocalTime lid+  subject <- partActorLeader aid+  -- The item may no longer be in @c@, but it was.+  itemToF <- getsState $ flip itemToFull+  let object (iid, (k, _)) =+        let itemFull = itemToF iid+        in case ekf k of+          Left (Just n) ->+            partItemWs rwidth side factionD n localTime itemFull fakeKit+          Left Nothing ->+            let (name, powers) =+                  partItem rwidth side factionD localTime itemFull fakeKit+            in MU.Phrase [name, powers]+          Right n ->+            let (name1, powers) =+                  partItemShort rwidth side factionD localTime itemFull fakeKit+            in MU.Phrase ["the", MU.Car1Ws n name1, powers]+      msg = makeSentence [ MU.SubjectVerbSg subject verb+                         , MU.WWandW $ map object sortedAssocs]+  msgAdd msgClass msg
+ engine-src/Game/LambdaHack/Client/UI/Watch/WatchQuitM.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE TupleSections #-}+-- | Display all the initial (not including high scores) screens at game over.+module Game.LambdaHack.Client.UI.Watch.WatchQuitM+  ( quitFactionUI+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , displayGameOverLoot, displayGameOverAnalytics, displayGameOverLore+  , viewFinalLore+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.HandleHelperM+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Analytics+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++quitFactionUI :: MonadClientUI m+              => FactionId -> Maybe Status+              -> Maybe (FactionAnalytics, GenerationAnalytics)+              -> m ()+quitFactionUI fid toSt manalytics = do+  side <- getsClient sside+  gameModeId <- getsState sgameModeId+  when (side == fid) $ case toSt of+    Just Status{stOutcome=Camping} ->+      modifySession $ \sess ->+        sess {scampings = ES.insert gameModeId $ scampings sess}+    Just Status{stOutcome=Restart} ->+      modifySession $ \sess ->+        sess {srestarts = ES.insert gameModeId $ srestarts sess}+    Just Status{stOutcome} | stOutcome `elem` victoryOutcomes -> do+      scurChal <- getsClient scurChal+      let sing = M.singleton scurChal 1+          f = M.unionWith (+)+          g = EM.insertWith f gameModeId sing+      modifySession $ \sess -> sess {svictories = g $ svictories sess}+    _ -> return ()+  ClientOptions{sexposeItems} <- getsClient soptions+  fact <- getsState $ (EM.! fid) . sfactionD+  let fidName = MU.Text $ gname fact+      person = if fhasGender $ gkind fact then MU.PlEtc else MU.Sg3rd+      horror = isHorrorFact fact+      camping = maybe True ((== Camping) . stOutcome) toSt+  when (fid == side && not camping) $ do+    tellGameClipPS+    resetGameStart+  gameMode <- getGameMode+  allNframes <- getsSession sallNframes+  let startingPart = case toSt of+        _ | horror -> Nothing  -- Ignore summoned actors' factions.+        Just Status{stOutcome=stOutcome@Restart, stNewGame=Just gn} ->+          Just $ MU.Text $ nameOutcomeVerb stOutcome+                           <+> "to restart in"+                           <+> displayGroupName gn+                           <+> "mode"+                             -- when multiplayer: "order mission restart in"+        Just Status{stOutcome=Restart, stNewGame=Nothing} ->+          error $ "" `showFailure` (fid, toSt)+        Just Status{stOutcome} -> Just $ MU.Text $ nameOutcomeVerb stOutcome+          -- when multiplayer, for @Camping@: "order save and exit"+        Nothing -> Nothing+      middlePart = case toSt of+        _ | fid /= side -> Nothing+        Just Status{stOutcome} -> lookup stOutcome $ mendMsg gameMode+        Nothing -> Nothing+      partingPart = if fid /= side || allNframes == -1+                    then Nothing+                    else endMessageOutcome . stOutcome <$> toSt+  case startingPart of+    Nothing -> return ()+    Just sp ->+      let blurb = makeSentence [MU.SubjectVerb person MU.Yes fidName sp]+      in msgLnAdd MsgFinalOutcome blurb+  case (toSt, partingPart) of+    (Just status, Just pp) -> do+      noConfirmsGame <- isNoConfirmsGame+      go <- if noConfirmsGame+            then return False+            else displaySpaceEsc ColorFull ""  -- short, just @startingPart@+      recordHistory+        -- we are going to exit or restart, so record and clear, but only once+      (itemBag, total) <- getsState $ calculateTotal side+      when go $ do+        case middlePart of+          Nothing -> return ()+          Just sp1 -> do+            factionD <- getsState sfactionD+            itemToF <- getsState $ flip itemToFull+            let getTrunkFull (aid, b) = (aid, itemToF $ btrunk b)+            ourTrunks <- getsState $ map getTrunkFull+                                     . fidActorNotProjGlobalAssocs side+            let smartFaction fact2 = fhasPointman (gkind fact2)+                canBeSmart = any (smartFaction . snd)+                canBeOurFaction = any (\(fid2, _) -> fid2 == side)+                smartEnemy trunkFull =+                  let possible =+                        possibleActorFactions [] (itemKind trunkFull) factionD+                  in not (canBeOurFaction possible) && canBeSmart possible+                smartEnemiesOurs = filter (smartEnemy . snd) ourTrunks+                uniqueActor trunkFull = IA.checkFlag Ability.Unique+                                        $ aspectRecordFull trunkFull+                uniqueEnemiesOurs = filter (uniqueActor . snd) smartEnemiesOurs+                smartUniqueEnemyCaptured = not $ null uniqueEnemiesOurs+                smartEnemyCaptured = not $ null smartEnemiesOurs+            smartEnemySentence <- case uniqueEnemiesOurs ++ smartEnemiesOurs of+              [] -> return ""+              (enemyAid, _) : _ -> do+                bUI <- getsSession $ getActorUI enemyAid+                return $! makePhrase [MU.Capitalize (partActor bUI)] <> "?"+            let won = maybe False ((`elem` victoryOutcomes) . stOutcome) toSt+                lost = maybe False ((`elem` deafeatOutcomes) . stOutcome) toSt+                msgClass | won = MsgGoodMiscEvent+                         | lost = MsgBadMiscEvent+                         | otherwise = MsgNeutralEvent+                (sp2, escPrompt) =+                  if | lost -> ("", "Accept the unacceptable?")+                     | smartUniqueEnemyCaptured ->+                       ( "\nOh, wait, who is this, towering behind your escaping crew?" <+> smartEnemySentence <+> "This changes everything. For everybody. Everywhere. Forever. Did you plan for this? Are you sure it was your idea?"+                       , "What happens now?" )+                     | smartEnemyCaptured ->+                       ( "\nOh, wait, who is this, hunched among your escaping crew?" <+> smartEnemySentence <+> "Suddenly, this makes your crazy story credible. Suddenly, the door of knowledge opens again."+                       , "How will you play that move?" )+                     | otherwise -> ("", "Let's see what we've got here.")+            msgAdd msgClass sp1+            msgAdd MsgFactionIntel sp2+            void $ displaySpaceEsc ColorFull escPrompt+        case manalytics of+          Nothing -> return ()+          Just (factionAn, generationAn) ->+            cycleLore []+              [ displayGameOverLoot (itemBag, total) generationAn+              , displayGameOverLore SOrgan True generationAn+              , displayGameOverAnalytics factionAn generationAn+              , displayGameOverLore SCondition sexposeItems generationAn+              , displayGameOverLore SBlast True generationAn+              , displayGameOverLore SEmbed True generationAn ]+      go2 <- if noConfirmsGame then return False else do+        -- Show score for any UI client after any kind of game exit,+        -- even though it's saved only for human UI clients at game over+        -- (that is not a noConfirms or benchmark game).+        scoreSlides <- scoreToSlideshow total status+        km <- getConfirms ColorFull [K.spaceKM, K.escKM] scoreSlides+        return $! km == K.spaceKM+      let epilogue = do+            when camping $ msgAdd MsgPromptGeneric "Saving..."+            -- Don't leave frozen old prompts on the browser screen.+            pushReportFrame+      if go2 && not noConfirmsGame && not camping then do+        msgAdd MsgPromptGeneric $ pp <+> "(Press RET to have one last look at the arena of your struggle before it gets forgotten.)"+        slides <-+          reportToSlideshowKeepHalt True [K.returnKM, K.spaceKM, K.escKM]+        km <- getConfirms ColorFull [K.returnKM, K.spaceKM, K.escKM] slides+        if km == K.returnKM then do+          -- Enter aiming mode. At exit, game arena is wiped out.+          lidV <- viewedLevelUI+          let saimMode = Just $ AimMode lidV defaultDetailLevel+          modifySession $ \sess -> sess { sreqDelay = ReqDelayHandled+                                        , saimMode }+        else epilogue+      else do+        when (not noConfirmsGame || camping) $ do+          -- The last prompt stays onscreen during shutdown, etc.+          msgAdd MsgPromptGeneric pp+          epilogue+    _ ->+      when (isJust startingPart && (stOutcome <$> toSt) == Just Killed) $ do+        msgAdd MsgTutorialHint "When a whole faction gets eliminated, no new members of the party will ever appear and its stashed belongings may remain far off, unclaimed and undefended. While some adventures require elimination a faction (to be verified in the adventure description screen in the help menu), for others it's an optional task, if possible at all. Instead, finding an exit may be necessary to win. It's enough if one character finds and triggers the exit. Others automatically follow, duly hauling all common belongings. Similarly, if eliminating foes ends a challenge, it happens immediately, with no need to move party members anywhere."+        -- Needed not to overlook the competitor dying in raid scenario.+        displayMore ColorFull "This is grave news. What now?"++displayGameOverLoot :: MonadClientUI m+                    => (ItemBag, Int) -> GenerationAnalytics -> m K.KM+displayGameOverLoot (heldBag, total) generationAn = do+  ClientOptions{sexposeItems} <- getsClient soptions+  COps{coitem} <- getsState scops+  -- We assume "gold grain", not "grain" with label "of gold":+  let currencyName = IK.iname $ okind coitem $ ouniqGroup coitem IK.S_CURRENCY+      generationItem = generationAn EM.! SItem+      itemBag =+        if sexposeItems+        then let generationBag = EM.map (\k -> (-k, [])) generationItem+             in heldBag `EM.union` generationBag+        else heldBag+      promptFun iid itemFull2 k =+        let worth = itemPrice 1 $ itemKind itemFull2+            lootMsg = if worth == 0 then "" else+              let pile = if k <= 1 then "exemplar" else "hoard"+              in makeSentence $+                   ["this treasure", pile, "is worth"]+                   ++ (if k > 1 then [ MU.Cardinal k, "times"] else [])+                   ++ [MU.CarWs worth $ MU.Text currencyName]+            holdsMsg =+              let n = generationItem EM.! iid+              in if | max 0 k == 1 && n == 1 ->+                      "You keep the only specimen extant:"+                    | max 0 k == 0 && n == 1 ->+                      "You don't have the only hypothesized specimen:"+                    | max 0 k == 0 && n == 0 ->+                      "No such specimen was recorded:"+                    | otherwise ->+                        makePhrase [ "You hold"+                                   , if k == n+                                     then "all pieces"+                                     else MU.CardinalAWs (max 0 k) "piece"+                                   , "out of"+                                   , MU.Car n+                                   , "scattered:" ]+        in lootMsg <+> holdsMsg+  dungeonTotal <- getsState sgold+  let promptGold = spoilsBlurb currencyName total dungeonTotal+      -- Total number of items is meaningless in the presence of so much junk.+      prompt =+        promptGold+        <+> (if sexposeItems+             then "Non-positive count means none held but this many generated."+             else "")+  viewFinalLore "GameOverLoot" itemBag prompt promptFun (MLore SItem)++displayGameOverAnalytics :: MonadClientUI m+                         => FactionAnalytics -> GenerationAnalytics+                         -> m K.KM+displayGameOverAnalytics factionAn generationAn = do+  ClientOptions{sexposeActors} <- getsClient soptions+  side <- getsClient sside+  ItemRoles itemRoles <- getsSession sroles+  let ourAn = akillCounts+              $ EM.findWithDefault emptyAnalytics side factionAn+      foesAn = EM.unionsWith (+) $ concatMap EM.elems+               $ mapMaybe (`EM.lookup` ourAn)+                          [KillKineticMelee .. KillOtherPush]+      killedBagIncludingProjectiles = EM.map (, []) foesAn+      killedBag = EM.filterWithKey+                    (\iid _ -> iid `ES.member` (itemRoles EM.! STrunk))+                    killedBagIncludingProjectiles+      generationTrunk = generationAn EM.! STrunk+      trunkBag =+        if sexposeActors+        then let generationBag = EM.map (\k -> (-k, [])) generationTrunk+             in killedBag `EM.union` generationBag+        else killedBag+      total = sum $ filter (> 0) $ map fst $ EM.elems trunkBag+      -- Not just "killed 1 out of 4", because it's sometimes "2 out of 1",+      -- if an enemy was revived.+      promptFun :: ItemId -> ItemFull-> Int -> Text+      promptFun iid _ k =+        let n = generationTrunk EM.! iid+        in makePhrase [ "You recall the adversary, which you killed on"+                      , MU.CarWs (max 0 k) "occasion", "while reports mention"+                      , MU.CarWs n "individual", "in total:" ]+      prompt =+        makeSentence ["your team vanquished", MU.CarWs total "adversary"]+          -- total reported would include our own, so not given+        <+> (if sexposeActors+             then "Non-positive count means none killed but this many reported."+             else "")+  viewFinalLore "GameOverAnalytics" trunkBag prompt promptFun (MLore STrunk)++displayGameOverLore :: MonadClientUI m+                    => SLore -> Bool -> GenerationAnalytics -> m K.KM+displayGameOverLore slore exposeCount generationAn = do+  itemD <- getsState sitemD+  let -- In @sexposeItems@ mode this filtering passes all through+      -- thanks to @revealItems@.+      generationLore = EM.filterWithKey (\iid _ -> iid `EM.member` itemD)+                       $ generationAn EM.! slore+      generationBag = EM.map (\k -> (if exposeCount then k else 1, []))+                             generationLore+      total = sum $ map fst $ EM.elems generationBag+      promptFun :: ItemId -> ItemFull-> Int -> Text+      promptFun _ _ k =+        makeSentence+          [ "this", MU.Text (ppSLore slore), "manifested during your quest"+          , MU.CarWs k "time" ]+      verb = if | slore `elem` [SCondition, SBlast] -> "experienced"+                | slore == SEmbed -> "ambled among"+                | otherwise -> "lived among"+      prompt = case total of+        0 -> makeSentence [ "you didn't experience any"+                          , MU.Ws $ MU.Text (headingSLore slore)+                          , "this time" ]+        1 -> makeSentence [ "you saw the following"+                          , MU.Text (headingSLore slore) ]+        _ -> makeSentence [ "you", verb, "the following variety of"+                          , MU.CarWs total $ MU.Text (headingSLore slore) ]+  viewFinalLore ("GameOverLore" ++ show slore)+                generationBag prompt promptFun (MLore slore)++viewFinalLore :: forall m . MonadClientUI m+              => String -> ItemBag -> Text+              -> (ItemId -> ItemFull -> Int -> Text)+              -> ItemDialogMode+              -> m K.KM+viewFinalLore menuName trunkBag prompt promptFun dmode = do+  CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui+  itemToF <- getsState $ flip itemToFull+  let iids = sortIids itemToF $ EM.assocs trunkBag+      viewAtSlot :: MenuSlot -> m K.KM+      viewAtSlot slot = do+        let renderOneItem = okxItemLoreMsg promptFun 0 dmode iids+            extraKeys = []+            slotBound = length iids - 1+        km <- displayOneMenuItem renderOneItem extraKeys slotBound slot+        case K.key km of+          K.Space -> viewFinalLore menuName trunkBag prompt promptFun dmode+          K.Esc -> return km+          _ -> error $ "" `showFailure` km+  msgAdd MsgPromptGeneric prompt+  let keys = [K.spaceKM, K.mkChar '<', K.mkChar '>', K.escKM]+  okx <- itemOverlay iids dmode+  sli <- overlayToSlideshow (rheight - 2) keys okx+  ekm <- displayChoiceScreenWithDefItemKey+           (okxItemLoreInline promptFun 0 dmode iids) sli keys menuName+  case ekm of+    Left km | km `elem` keys -> return km+    Left km -> error $ "" `showFailure` km+    Right slot -> viewAtSlot slot
+ engine-src/Game/LambdaHack/Client/UI/Watch/WatchSfxAtomicM.hs view
@@ -0,0 +1,992 @@+-- | Display atomic SFX commands received by the client.+module Game.LambdaHack.Client.UI.Watch.WatchSfxAtomicM+  ( watchRespSfxAtomicUI+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , returnJustLeft, ppSfxMsg, strike+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import           Data.Int (Int64)+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Atomic (SfxAtomic (..), SfxMsg (..))+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Animation+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.EffectDescription+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.HandleHelperM+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import           Game.LambdaHack.Client.UI.ItemDescription+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Client.UI.TutorialHints (TutorialHints (..))+import           Game.LambdaHack.Client.UI.Watch.WatchCommonM+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.CaveKind (cdesc)+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs++-- | Display special effects (text, animation) sent to the client.+-- Don't modify client state (except a few fields), but only client+-- session (e.g., by displaying messages). This is enforced by types.+watchRespSfxAtomicUI :: MonadClientUI m => SfxAtomic -> m ()+{-# INLINE watchRespSfxAtomicUI #-}+watchRespSfxAtomicUI sfx = case sfx of+  SfxStrike source target iid ->+    strike False source target iid+  SfxRecoil source target iid -> do+    sourceSeen <- getsState $ EM.member source . sactorD+    if not sourceSeen then do+      tb <- getsState $ getActorBody target+      animate (blid tb) $ blockMiss (bpos tb, bpos tb)+    else do+      CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+      sb <- getsState $ getActorBody source+      tb <- getsState $ getActorBody source+      spart <- partActorLeader source+      tpart <- partActorLeader target+      side <- getsClient sside+      factionD <- getsState sfactionD+      localTime <- getsState $ getLocalTime (blid tb)+      itemFullWeapon <- getsState $ itemToFull iid+      let kitWeapon = quantSingle+          (weaponName, _) = partItemShort rwidth side factionD+                                          localTime itemFullWeapon kitWeapon+          weaponNameOwn = partItemShortWownW rwidth side factionD spart+                                             localTime itemFullWeapon kitWeapon+          verb = if bproj sb then "deflect" else "fend off"+          objects | iid == btrunk sb = ["the", spart]+                  | iid `EM.member` borgan sb =  ["the", weaponNameOwn]+                  | otherwise = ["the", weaponName, "of", spart]+      msgAdd MsgActionMajor $+        makeSentence $ MU.SubjectVerbSg tpart verb : objects+      animate (blid tb) $ blockMiss (bpos tb, bpos sb)+  SfxSteal source target iid ->+    strike True source target iid+  SfxRelease source target _ -> do+    spart <- partActorLeader source+    tpart <- partActorLeader target+    msgAdd MsgActionMajor $+      makeSentence [MU.SubjectVerbSg spart "release", tpart]+  SfxProject aid iid ->+    itemAidVerbMU MsgActionMajor aid "fling" iid (Left 1)+  SfxReceive aid iid ->+    itemAidVerbMU MsgActionMajor aid "receive" iid (Left 1)+  SfxApply aid iid -> do+    CCUI{coscreen=ScreenContent{rapplyVerbMap}} <- getsSession sccui+    ItemFull{itemKind} <- getsState $ itemToFull iid+    let actionPart =+          maybe "trigger"+                MU.Text+                (EM.lookup (IK.isymbol itemKind) rapplyVerbMap)+    itemAidVerbMU MsgActionMajor aid actionPart iid (Left 1)+  SfxCheck aid iid ->+    itemAidVerbMU MsgActionMajor aid "recover" iid (Left 1)+  SfxTrigger _ _ _ fromTile -> do+    COps{cotile} <- getsState scops+    let subject = MU.Text $ TK.tname $ okind cotile fromTile+        verb = "shake"+        msg = makeSentence ["the", MU.SubjectVerbSg subject verb]+    msgAdd MsgNeutralEvent msg+  SfxShun aid _ _ _ ->+    aidVerbMU MsgActionMajor aid "shun it"+  SfxEffect fidSource aid iid effect hpDelta -> do+    -- In most messages below @iid@ is ignored, because it's too common,+    -- e.g., caused by some combat hits, or rather obvious,+    -- e.g., in case of embedded items, or would be counterintuitive,+    -- e.g., when actor is said to be intimidated by a particle, not explosion.+    CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+    b <- getsState $ getActorBody aid+    bUI <- getsSession $ getActorUI aid+    side <- getsClient sside+    mleader <- getsClient sleader+    itemD <- getsState sitemD+    actorMaxSk <- getsState $ getActorMaxSkills aid+    let fid = bfid b+        isOurCharacter = fid == side && not (bproj b)+        isAlive = bhp b > 0+        isOurAlive = isOurCharacter && isAlive+        isOurLeader = Just aid == mleader+        -- The message classes are close enough. It's melee or similar.+        feelLookHPBad bigAdj projAdj = do+          feelLook MsgBadMiscEvent MsgGoodMiscEvent bigAdj projAdj+          -- We can't know here if the hit was in melee, ranged or+          -- even triggering a harmful item. However, let's not talk+          -- about armor before the player has the most basic one.+          -- for melee. Most of the time the first hit in the game is,+          -- in fact, from melee, so that's a sensible default.+          --+          -- Note that the @idamage@ is called piercing (or edged) damage,+          -- even though the distinction from impact damage is fleshed+          -- out only in Allure.+          when (isOurCharacter+                && Ability.getSk Ability.SkArmorMelee actorMaxSk > 0) $+            tutorialHintMsgAdd DamageOfDifferentKind+        feelLookHPGood = feelLook MsgGoodMiscEvent MsgBadMiscEvent+        feelLookCalm bigAdj projAdj = when isAlive $+          feelLook MsgEffectMinor MsgEffectMinor bigAdj projAdj+        -- Ignore @iid@, because it's usually obvious what item caused that+        -- and because the effects are not particularly disortienting.+        feelLook msgClassOur msgClassTheir bigAdj projAdj =+          let (verb, adjective) =+                if bproj b+                then ("get", projAdj)+                else ( if isOurCharacter then "feel" else "look"+                     , if isAlive then bigAdj else projAdj )+                         -- dead body is an item, not a person+              msgClass = if | bproj b -> MsgEffectMinor+                            | isOurCharacter -> msgClassOur+                            | otherwise -> msgClassTheir+          in aidVerbMU msgClass aid $ MU.Text $ verb <+> adjective+    case effect of+      IK.Burn{} -> do+        feelLookHPBad "burned" "scorched"+        let ps = (bpos b, bpos b)+        animate (blid b) $ twirlSplash ps Color.BrRed Color.Brown+      IK.Explode{} -> return ()  -- lots of visual feedback+      IK.RefillHP p | p == 1 -> return ()  -- no spam from regeneration+      IK.RefillHP p | p == -1 -> return ()  -- no spam from poison+      IK.RefillHP{} | hpDelta > 0 -> do+        feelLookHPGood "healthier" "mended"+        let ps = (bpos b, bpos b)+        animate (blid b) $ twirlSplash ps Color.BrGreen Color.Green+      IK.RefillHP{} -> do+        feelLookHPBad "wounded" "broken"+        let ps = (bpos b, bpos b)+        animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+      IK.RefillCalm{} | not isAlive -> return ()+      IK.RefillCalm{} | bproj b -> return ()+      IK.RefillCalm p | p == 1 -> return ()  -- no spam from regen items+      IK.RefillCalm p | p > 0 -> feelLookCalm "calmer" "stabilized"+      IK.RefillCalm _ -> feelLookCalm "agitated" "wobbly"+      IK.Dominate | not isAlive -> return ()+      IK.Dominate -> do+        -- For subsequent messages use the proper name, never "you".+        let subject = partActor bUI+        if fid /= fidSource then do+          -- Before domination, possibly not seen if actor (yet) not ours.+          if bcalm b == 0  -- sometimes only a coincidence, but nm+          then aidVerbMU MsgEffectMedium aid "yield, under extreme pressure"+          else do+            let verb = if isOurAlive+                       then "black out, dominated by foes"+                       else "decide abruptly to switch allegiance"+                -- Faction is being switched, so item that caused domination+                -- and vanished may not be known to the new faction.+                msuffix = if iid == btrunk b || iid `EM.notMember` itemD+                          then Nothing+                          else Just $ if isOurAlive+                                      then "through"+                                      else "under the influence of"+            mitemAidVerbMU MsgEffectMedium aid verb iid msuffix+          fidNameRaw <- getsState $ gname . (EM.! fid) . sfactionD+          -- Avoid "controlled by Controlled foo".+          let fidName = T.unwords $ tail $ T.words fidNameRaw+              verb = "be no longer controlled by"+          msgLnAdd MsgEffectMajor $ makeSentence+            [MU.SubjectVerbSg subject verb, MU.Text fidName]+          when isOurAlive $ displayMoreKeep ColorFull ""  -- Ln makes it short+        else do+          -- After domination, possibly not seen, if actor (already) not ours.+          fidSourceNameRaw <- getsState $ gname . (EM.! fidSource) . sfactionD+          -- Avoid "Controlled control".+          let fidSourceName = T.unwords $ tail $ T.words fidSourceNameRaw+              verb = "be now under"+          msgAdd MsgEffectMajor $ makeSentence+            [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]+      IK.Impress | not isAlive -> return ()+      IK.Impress -> aidVerbMU MsgEffectMinor aid "be awestruck"+      IK.PutToSleep | not isAlive -> return ()+      IK.PutToSleep -> do+        let verb = "be put to sleep"+            msuffix = Just $ if fidSource == bfid b then "due to" else "by"+        mitemAidVerbMU MsgEffectMajor aid verb iid msuffix+      IK.Yell | not isAlive -> return ()+      IK.Yell -> aidVerbMU MsgMiscellanous aid "start"+      IK.Summon grp p -> do+        let verbBase = if bproj b then "lure" else "summon"+            part = MU.Text $ displayGroupName grp+            object = if p == 1  -- works, because exact number sent, not dice+                     then MU.AW part+                     else MU.Ws part+            verb = MU.Phrase [verbBase, object]+            msuffix = Just "with"+        mitemAidVerbMU MsgEffectMajor aid verb iid msuffix+      IK.Ascend{} | not isAlive -> return ()+      IK.Ascend up -> do+        COps{cocave} <- getsState scops+        aidVerbMU MsgEffectMajor aid $ MU.Text $+          "find a way" <+> if up then "upstairs" else "downstairs"+        when isOurLeader $ do+          destinations <- getsState $ whereTo (blid b) (bpos b) up+                                      . sdungeon+          case destinations of+            (lid, _) : _ -> do  -- only works until different levels possible+              lvl <- getLevel lid+              let desc = cdesc $ okind cocave $ lkind lvl+              unless (T.null desc) $+                msgAdd MsgBackdropInfo $ desc <> "\n"+              tutorialHintMsgAdd NewFloorNewOpportunity+            [] -> return ()  -- spell fizzles; normally should not be sent+      IK.Escape{} | isOurCharacter -> do+        ours <- getsState $ fidActorNotProjGlobalAssocs side+        when (length ours > 1) $ do+          (_, total) <- getsState $ calculateTotal side+          if total == 0+          then msgAdd MsgFactionIntel $+                 "The team joins" <+> makePhrase [partActor bUI]+                 <> ", forms a perimeter and leaves triumphant."+          else msgAdd MsgItemCreation $+                 "The team joins" <+> makePhrase [partActor bUI]+                 <> ", forms a perimeter, repacks its belongings and leaves triumphant."+      IK.Escape{} -> return ()+      IK.Paralyze{} | not isAlive -> return ()+      IK.Paralyze{} ->+        mitemAidVerbMU MsgEffectMedium aid "be paralyzed" iid (Just "with")+      IK.ParalyzeInWater{} | not isAlive -> return ()+      IK.ParalyzeInWater{} ->+        aidVerbMU MsgEffectMinor aid "move with difficulty"+      IK.InsertMove{} | not isAlive -> return ()+      IK.InsertMove d ->+        -- Usually self-inflicted of from embeds, so obvious, so no @iid@.+        if Dice.supDice d >= 10+        then aidVerbMU MsgEffectMedium aid "act with extreme speed"+        else do+          let msgClass = if isOurCharacter+                         then MsgEffectMedium+                         else MsgEffectMinor+          aidVerbMU msgClass aid "move swiftly"+      IK.Teleport t | Dice.supDice t <= 9 -> do+        -- Actor may be sent away before noticing the item that did it.+        let msuffix = if iid `EM.notMember` itemD+                      then Nothing+                      else Just "due to"+            msgClass = if isOurCharacter+                       then MsgEffectMedium+                       else MsgEffectMinor+        mitemAidVerbMU msgClass aid "blink" iid msuffix+      IK.Teleport{} -> do+        -- Actor may be sent away before noticing the item that did it.+        let msuffix = if iid `EM.notMember` itemD+                      then Nothing+                      else Just "by the power of"+        mitemAidVerbMU MsgEffectMedium aid "teleport" iid msuffix+      IK.CreateItem{} -> return ()+      IK.DestroyItem{} -> return ()+      IK.ConsumeItems{} -> return ()+      IK.DropItem _ _ COrgan _ -> return ()+      IK.DropItem{} ->  -- rare enough+        mitemAidVerbMU MsgEffectMedium aid "be stripped" iid (Just "with")+      IK.Recharge{} | not isAlive -> return ()+      IK.Recharge{} -> aidVerbMU MsgEffectMedium aid "charge up"+      IK.Discharge{} | not isAlive -> return ()+      IK.Discharge{} -> aidVerbMU MsgEffectMedium aid "lose charges"+      IK.PolyItem -> do+        subject <- partActorLeader aid+        let ppstore = MU.Text $ ppCStoreIn CGround+        msgAdd MsgEffectMedium $ makeSentence+          [ MU.SubjectVerbSg subject "repurpose", "what lies", ppstore+          , "to a common item of the current level" ]+      IK.RerollItem -> do+        subject <- partActorLeader aid+        let ppstore = MU.Text $ ppCStoreIn CGround+        msgAdd MsgEffectMedium $ makeSentence+          [ MU.SubjectVerbSg subject "reshape", "what lies", ppstore+          , "striving for the highest possible standards" ]+      IK.DupItem -> do+        subject <- partActorLeader aid+        let ppstore = MU.Text $ ppCStoreIn CGround+        msgAdd MsgEffectMedium $ makeSentence+          [MU.SubjectVerbSg subject "multiply", "what lies", ppstore]+      IK.Identify -> do+        subject <- partActorLeader aid+        pronoun <- partPronounLeader aid+        msgAdd MsgEffectMinor $ makeSentence+          [ MU.SubjectVerbSg subject "look at"+          , MU.WownW pronoun $ MU.Text "inventory"+          , "intensely" ]+      IK.Detect d _ -> do+        subject <- partActorLeader aid+        factionD <- getsState sfactionD+        localTime <- getsState $ getLocalTime $ blid b+        let verb = MU.Text $ detectToVerb d+            object = MU.Ws $ MU.Text $ detectToObject d+        (periodic, itemFull) <-+          if iid `EM.member` itemD then do+            itemFull <- getsState $ itemToFull iid+            let arItem = aspectRecordFull itemFull+            return (IA.checkFlag Ability.Periodic arItem, itemFull)+          else do+#ifdef WITH_EXPENSIVE_ASSERTIONS+            -- It's not actually expensive, but it's particularly likely+            -- to fail with wild content, indicating server game rules logic+            -- needs to be fixed/extended:+            -- Observer from another faction may receive the effect information+            -- from the server, because the affected actor is visible,+            -- but the position of the item may be out of FOV. This is fine;+            -- the message is then shorter, because only the effect was seen,+            -- while the cause remains misterious.+            let !_A = if fid /= side  -- not from affected faction; observing+                      then ()+                      else error $ "item never seen by the affected actor"+                                   `showFailure` (aid, b, bUI, verb, iid, sfx)+#endif+            return (False, undefined)+        let iidDesc =+              let (name1, powers) = partItemShort rwidth side factionD localTime+                                                  itemFull quantSingle+              in makePhrase ["the", name1, powers]+            -- If item not periodic, most likely intentional, so don't spam.+            means = [MU.Text $ "(via" <+> iidDesc <> ")" | periodic]+        msgAdd MsgEffectMinor $+          makeSentence $ [MU.SubjectVerbSg subject verb] ++ [object] ++ means+        -- Don't make it modal if all info remains after no longer seen.+        unless (fid /= side || d `elem` [IK.DetectHidden, IK.DetectExit]) $+          displayMore ColorFull ""  -- the sentence short+      IK.SendFlying{} | not isAlive -> return ()+      IK.SendFlying{} -> aidVerbMU MsgEffectMedium aid "be sent flying"+      IK.PushActor{} | not isAlive -> return ()+      IK.PushActor{} -> aidVerbMU MsgEffectMedium aid "be pushed"+      IK.PullActor{} | not isAlive -> return ()+      IK.PullActor{} -> aidVerbMU MsgEffectMedium aid "be pulled"+      IK.ApplyPerfume ->+        msgAdd MsgEffectMinor+               "The fragrance quells all scents in the vicinity."+      IK.AtMostOneOf{} -> return ()+      IK.OneOf{} -> return ()+      IK.OnSmash{} -> error $ "" `showFailure` sfx+      IK.OnCombine{} -> error $ "" `showFailure` sfx+      IK.OnUser{} -> error $ "" `showFailure` sfx+      IK.NopEffect -> error $ "" `showFailure` sfx+      IK.AndEffect{} -> error $ "" `showFailure` sfx+      IK.OrEffect{} -> error $ "" `showFailure` sfx+      IK.SeqEffect{} -> error $ "" `showFailure` sfx+      IK.When{} -> error $ "" `showFailure` sfx+      IK.Unless{} -> error $ "" `showFailure` sfx+      IK.IfThenElse{} -> error $ "" `showFailure` sfx+      IK.VerbNoLonger{} | not isAlive -> return ()+      IK.VerbNoLonger verb ending -> do+        let msgClass = if fid == side+                       then MsgStatusStopUs+                       else MsgStatusStopThem+        subject <- partActorLeader aid+        msgAdd msgClass $+          makePhrase [MU.Capitalize $ MU.SubjectVerbSg subject $ MU.Text verb]+          <> ending+      IK.VerbMsg verb ending -> do+        subject <- partActorLeader aid+        msgAdd MsgEffectMedium $+          makePhrase [MU.Capitalize $ MU.SubjectVerbSg subject $ MU.Text verb]+          <> ending+      IK.VerbMsgFail verb ending -> do+        subject <- partActorLeader aid+        msgAdd MsgActionWarning $+          makePhrase [MU.Capitalize $ MU.SubjectVerbSg subject $ MU.Text verb]+          <> ending+  SfxItemApplied verbose iid c -> do+    if verbose+    then itemVerbMU MsgActionMinor iid (1, []) "have got activated" c+    else itemVerbMU MsgInnerWorkSpam iid (1, []) "have been triggered" c+  SfxMsgFid _ sfxMsg -> do+    mleader <- getsClient sleader+    case mleader of+      Just{} -> return ()  -- will flush messages when leader moves+      Nothing -> do+        lidV <- viewedLevelUI+        markDisplayNeeded lidV+        recordHistory+    mmsg <- ppSfxMsg sfxMsg+    case mmsg of+      Just (Left (msgClass, msg)) -> msgAdd msgClass msg+      Just (Right (msgClass, (t1, t2))) -> do+        let dotsIfShorter = if t1 == t2 then "" else ".."+        msgAddDistinct msgClass  (t1 <> dotsIfShorter, t2)+      Nothing -> return ()+  SfxRestart -> fadeOutOrIn True+  SfxCollideTile source pos -> do+    COps{cotile} <- getsState scops+    sb <- getsState $ getActorBody source+    lvl <- getLevel $ blid sb+    spart <- partActorLeader source+    let object = MU.AW $ MU.Text $ TK.tname $ okind cotile $ lvl `at` pos+    -- Neutral message, because minor damage and we don't say, which faction.+    msgAdd MsgNeutralEvent $! makeSentence+      [MU.SubjectVerbSg spart "collide", "painfully with", object]+  SfxTaunt voluntary aid -> do+    side <- getsClient sside+    b <- getsState $ getActorBody aid+    unless (bproj b && bfid b == side) $ do  -- don't spam+      spart <- partActorLeader aid+      (_heardSubject, verb) <- displayTaunt voluntary rndToActionUI aid+      let msgClass = if voluntary && bfid b == side+                     then MsgActionComplete  -- give feedback after keypress+                     else MsgMiscellanous+      msgAdd msgClass $! makeSentence [MU.SubjectVerbSg spart (MU.Text verb)]++returnJustLeft :: MonadClientUI m+               => (MsgClassShowAndSave, Text)+               -> m (Maybe (Either (MsgClassShowAndSave, Text)+                                   (MsgClassDistinct, (Text, Text))))+returnJustLeft = return . Just . Left++ppSfxMsg :: MonadClientUI m+         => SfxMsg -> m (Maybe (Either (MsgClassShowAndSave, Text)+                                       (MsgClassDistinct, (Text, Text))))+ppSfxMsg sfxMsg = case sfxMsg of+  SfxUnexpected reqFailure -> returnJustLeft+    ( MsgActionWarning+    , "Unexpected problem:" <+> showReqFailure reqFailure <> "." )+  SfxExpected itemName reqFailure -> returnJustLeft+    ( MsgActionWarning+    , "The" <+> itemName <+> "is not triggered:"+      <+> showReqFailure reqFailure <> "." )+  SfxExpectedEmbed iid lid reqFailure -> do+    iidSeen <- getsState $ EM.member iid . sitemD+    if iidSeen then do+      itemFull <- getsState $ itemToFull iid+      side <- getsClient sside+      factionD <- getsState sfactionD+      localTime <- getsState $ getLocalTime lid+      let (object1, object2) =+            partItemShortest maxBound side factionD localTime+                             itemFull quantSingle+          name = makePhrase [object1, object2]+      returnJustLeft+        ( MsgActionWarning+        , "The" <+> "embedded" <+> name <+> "is not activated:"+          <+> showReqFailure reqFailure <> "." )+    else return Nothing+  SfxFizzles iid c -> do+    msg <- itemVerbMUGeneral True iid (1, []) "do not work" c+    return $ Just $ Right (MsgStatusWarning, ("It didn't work.", msg))+  SfxNothingHappens iid c -> do+    msg <- itemVerbMUGeneral True iid (1, []) "do nothing, predictably" c+    return $ Just $ Right (MsgStatusBenign, ("Nothing happens.", msg))+  SfxNoItemsForTile toolsToAlterWith -> do+    revCmd <- revCmdMap+    let km = revCmd HumanCmd.AlterDir+        tItems = describeToolsAlternative toolsToAlterWith+    returnJustLeft ( MsgActionWarning+                   , "To transform the terrain, prepare the following items on the ground or in equipment:"+                     <+> tItems+                     <+> "and use the '"+                     <> T.pack (K.showKM km)+                     <> "' terrain modification command."+                   )+  SfxVoidDetection d -> returnJustLeft+    ( MsgMiscellanous+    , makeSentence ["no new", MU.Text $ detectToObject d, "detected"] )+  SfxUnimpressed aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return Nothing+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "be unimpressed"+        returnJustLeft ( MsgActionWarning+                       , makeSentence [MU.SubjectVerbSg subject verb] )+  SfxSummonLackCalm aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return Nothing+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "lack Calm to summon"+        returnJustLeft ( MsgActionWarning+                       , makeSentence [MU.SubjectVerbSg subject verb] )+  SfxSummonTooManyOwn aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return Nothing+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "can't keep track of their numerous friends, let alone summon any more"+        returnJustLeft (MsgActionWarning, makeSentence [subject, verb])+  SfxSummonTooManyAll aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return Nothing+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "can't keep track of everybody around, let alone summon anyone else"+        returnJustLeft (MsgActionWarning, makeSentence [subject, verb])+  SfxSummonFailure aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return Nothing+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "fail to summon anything"+        returnJustLeft ( MsgActionWarning+                       , makeSentence [MU.SubjectVerbSg subject verb] )+  SfxLevelNoMore -> returnJustLeft+    (MsgActionWarning, "No more levels in this direction.")+  SfxLevelPushed -> returnJustLeft+    (MsgActionWarning, "You notice somebody pushed to another level.")+  SfxBracedImmune aid -> do+    msbUI <- getsSession $ EM.lookup aid . sactorUI+    case msbUI of+      Nothing -> return Nothing+      Just sbUI -> do+        let subject = partActor sbUI+            verb = "be braced and so immune to translocation"+        returnJustLeft ( MsgMiscellanous+                       , makeSentence [MU.SubjectVerbSg subject verb] )+                         -- too common+  SfxEscapeImpossible -> returnJustLeft+    ( MsgActionWarning+    , "Escaping outside is unthinkable for members of this faction." )+  SfxStasisProtects -> returnJustLeft+    ( MsgMiscellanous  -- too common+    , "Paralysis and speed surge require recovery time." )+  SfxWaterParalysisResisted -> return Nothing  -- don't spam+  SfxTransImpossible -> returnJustLeft+    (MsgActionWarning, "Translocation not possible.")+  SfxIdentifyNothing -> returnJustLeft+    (MsgActionWarning, "Nothing to identify.")+  SfxPurposeNothing -> returnJustLeft+    ( MsgActionWarning+    , "The purpose of repurpose cannot be availed without an item"+      <+> ppCStoreIn CGround <> "." )+  SfxPurposeTooFew maxCount itemK -> returnJustLeft+    ( MsgActionWarning+    , "The purpose of repurpose is served by" <+> tshow maxCount+      <+> "pieces of this item, not by" <+> tshow itemK <> "." )+  SfxPurposeUnique -> returnJustLeft+    (MsgActionWarning, "Unique items can't be repurposed.")+  SfxPurposeNotCommon -> returnJustLeft+    (MsgActionWarning, "Only ordinary common items can be repurposed.")+  SfxRerollNothing -> returnJustLeft+    ( MsgActionWarning+    , "The shape of reshape cannot be assumed without an item"+      <+> ppCStoreIn CGround <> "." )+  SfxRerollNotRandom -> returnJustLeft+    (MsgActionWarning, "Only items of variable shape can be reshaped.")+  SfxDupNothing -> returnJustLeft+    ( MsgActionWarning+    , "Mutliplicity won't rise above zero without an item"+      <+> ppCStoreIn CGround <> "." )+  SfxDupUnique -> returnJustLeft+    (MsgActionWarning, "Unique items can't be multiplied.")+  SfxDupValuable -> returnJustLeft+    (MsgActionWarning, "Valuable items can't be multiplied.")+  SfxColdFish -> returnJustLeft+    ( MsgMiscellanous  -- repeatable+    , "Healing attempt from another faction is thwarted by your cold fish attitude." )+  SfxReadyGoods -> returnJustLeft+    ( MsgMiscellanous  -- repeatable+    , "Crafting is alien to you, accustomed to buying ready goods all your life." )+  SfxTimerExtended aid iid cstore delta -> do+    CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+    aidSeen <- getsState $ EM.member aid . sactorD+    iidSeen <- getsState $ EM.member iid . sitemD+    if aidSeen && iidSeen then do+      b <- getsState $ getActorBody aid+      bUI <- getsSession $ getActorUI aid+      factionD <- getsState sfactionD+      localTime <- getsState $ getLocalTime (blid b)+      itemFull <- getsState $ itemToFull iid+      side <- getsClient sside+      bag <- getsState $ getBodyStoreBag b cstore+      let (name, powers) =+            partItem rwidth (bfid b) factionD localTime itemFull quantSingle+          total = case bag EM.! iid of+            (_, []) -> error $ "" `showFailure` (bag, iid, aid, cstore, delta)+            (_, t:_) -> deltaOfItemTimer localTime t+              -- only exceptionally not singleton list+      storeOwn <- ppContainerWownW partPronounLeader True (CActor aid cstore)+      -- Ideally we'd use a pronoun here, but the action (e.g., hit)+      -- that caused this extension can be invisible to some onlookers.+      -- So their narrative context needs to be taken into account.+      -- The upside is that the messages do not bind pronouns+      -- and so commute and so repetitions can be squashed.+      let cond = [ "condition"+                 | IA.checkFlag Ability.Condition $ aspectRecordFull itemFull ]+          usShow =+            ["the", name, powers] ++ cond+            ++ storeOwn ++ ["will now last longer"]+          usSave =+            ["the", name, powers] ++ cond+            ++ storeOwn ++ ["will now last"]+            ++ [MU.Text $ timeDeltaInSecondsText delta <+> "longer"]+            ++ [MU.Text $ "(total:" <+> timeDeltaInSecondsText total <> ")"]+          -- Note that when enemy actor causes the extension to himself,+          -- the player is not notified at all. So the shorter blurb+          -- displayed on the screen is middle ground and full is in history.+          themShow =+            [partItemShortWownW rwidth side factionD (partActor bUI) localTime+                                itemFull quantSingle]+            ++ cond ++ ["is extended"]+          themSave =+            [partItemShortWownW rwidth side factionD (partActor bUI) localTime+                                itemFull quantSingle]+            ++ cond ++ ["is extended by"]+            ++ [MU.Text $ timeDeltaInSecondsText delta]+            ++ [MU.Text $ "(total:" <+> timeDeltaInSecondsText total <> ")"]+          (msgClass, parts1, parts2) =+            if bfid b == side+            then (MsgStatusLongerUs, usShow, usSave)+            else (MsgStatusLongThem, themShow, themSave)+      return $ Just $ Right+        (msgClass, (makeSentence parts1, makeSentence parts2))+    else return Nothing+  SfxCollideActor source target -> do+    sourceSeen <- getsState $ EM.member source . sactorD+    targetSeen <- getsState $ EM.member target . sactorD+    if sourceSeen && targetSeen then do+      spart <- partActorLeader source+      tpart <- partActorLeader target+      -- Neutral message, because minor damage and we don't say, which faction.+      -- And the collision may even be intentional.+      returnJustLeft+        ( MsgSpecialEvent+        , makeSentence+            [MU.SubjectVerbSg spart "collide", "awkwardly with", tpart] )+    else return Nothing+  SfxItemYield iid k lid -> do+    iidSeen <- getsState $ EM.member iid . sitemD+    if iidSeen then do+      let fakeKit = quantSingle+          fakeC = CFloor lid originPoint+          verb = MU.Text $ "yield" <+> makePhrase [MU.CardinalAWs k "item"]+      msg <- itemVerbMUGeneral False iid fakeKit verb fakeC+      returnJustLeft (MsgSpecialEvent, msg)  -- differentiate wrt item creation+    else return Nothing++strike :: MonadClientUI m => Bool -> ActorId -> ActorId -> ItemId -> m ()+strike catch source target iid = assert (source /= target) $ do+  sourceSeen <- getsState $ EM.member source . sactorD+  if not sourceSeen then do+    tb <- getsState $ getActorBody target+    animate (blid tb) $ blockMiss (bpos tb, bpos tb)+  else do+    CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+    tb <- getsState $ getActorBody target+    hurtMult <- getsState $ armorHurtBonus source target+    sb <- getsState $ getActorBody source+    sMaxSk <- getsState $ getActorMaxSkills source+    spart <- partActorLeader source+    tpart <- partActorLeader target+    spronoun <- partPronounLeader source+    tpronoun <- partPronounLeader target+    tbUI <- getsSession $ getActorUI target+    localTime <- getsState $ getLocalTime (blid tb)+    itemFullWeapon <- getsState $ itemToFull iid+    let kitWeapon = quantSingle+    side <- getsClient sside+    factionD <- getsState sfactionD+    tfact <- getsState $ (EM.! bfid tb) . sfactionD+    eqpOrgKit <- getsState $ kitAssocs target [CEqp, COrgan]+    orgKit <- getsState $ kitAssocs target [COrgan]+    let isCond (_, (itemFullArmor, _)) =+          IA.checkFlag Ability.Condition $ aspectRecordFull itemFullArmor+        -- We exclude genetic flaws, backstory items, etc., because they+        -- can't be easily taken off, so no point spamming the player.+        isOrdinaryCond ikit@(_, (itemFullArmor, _)) =+          not (IA.checkFlag Ability.MetaGame (aspectRecordFull itemFullArmor))+          && isCond ikit+        relevantSkArmor =+          if bproj sb then Ability.SkArmorRanged else Ability.SkArmorMelee+        rateArmor (iidArmor, (itemFullArmor, (k, _))) =+          ( k * IA.getSkill relevantSkArmor (aspectRecordFull itemFullArmor)+          , ( iidArmor+            , itemFullArmor ) )+        abs15 (v, _) = abs v >= 15+        condArmor = filter abs15 $ map rateArmor $ filter isOrdinaryCond orgKit+        fstGt0 (v, _) = v > 0+        wornArmor =+          filter fstGt0 $ map rateArmor $ filter (not . isCond) eqpOrgKit+    mblockArmor <- case wornArmor of+      [] -> return Nothing+      _ -> Just+           <$> rndToActionUI (frequency $ toFreq "msg armor" wornArmor)+    actorMaxSkills <- getsState sactorMaxSkills+    let (blockWithWhat, blockWithWeapon) = case mblockArmor of+          Just (iidArmor, itemFullArmor) | iidArmor /= btrunk tb ->+            let (object1, object2) =+                  partItemShortest rwidth (bfid tb) factionD localTime+                                   itemFullArmor quantSingle+                name = MU.Phrase [object1, object2]+            in ( ["with", MU.WownW tpronoun name]+               , Dice.supDice (IK.idamage $ itemKind itemFullArmor) > 0 )+          _ -> ([], False)+        verb = MU.Text $ IK.iverbHit $ itemKind itemFullWeapon+        partItemChoice =+          if iid `EM.member` borgan sb+          then partItemShortWownW rwidth side factionD spronoun localTime+          else partItemShortAW rwidth side factionD localTime+        weaponNameWith = if iid == btrunk sb+                         then []+                         else ["with", partItemChoice itemFullWeapon kitWeapon]+        sleepy = if bwatch tb `elem` [WSleep, WWake]+                    && tpart /= "you"+                    && bhp tb > 0+                 then "the sleepy"+                 else ""+        unBurn (IK.Burn d) = Just d+        unBurn _ = Nothing+        unRefillHP (IK.RefillHP n) | n < 0 = Just (-n)+        unRefillHP _ = Nothing+        kineticDmg =+          let dmg = Dice.supDice $ IK.idamage $ itemKind itemFullWeapon+              rawDeltaHP = into @Int64 sHurt * xM dmg `divUp` 100+          in case btrajectory sb of+            Just (_, speed) | bproj sb ->+              - modifyDamageBySpeed rawDeltaHP speed+            _ -> - rawDeltaHP+        burnDmg = - (sum $ map Dice.supDice+                     $ mapMaybe unBurn $ IK.ieffects $ itemKind itemFullWeapon)+        fillDmg =+          - (sum $ mapMaybe unRefillHP $ IK.ieffects $ itemKind itemFullWeapon)+        -- For variety, attack adverb is based on attacker's and weapon's+        -- damage potential as compared to victim's current HP.+        -- We are not taking into account victim's armor yet.+        sHurt = armorHurtCalculation (bproj sb) sMaxSk Ability.zeroSkills+        nonPiercingDmg = burnDmg + fillDmg+        sDamage = min 0 $ kineticDmg + xM nonPiercingDmg+        deadliness = 1000 * (- sDamage) `div` max 1 (bhp tb)+        strongly+          | deadliness >= 10000 = "artfully"+          | deadliness >= 5000 = "madly"+          | deadliness >= 2000 = "mercilessly"+          | deadliness >= 1000 = "murderously"  -- one blow can wipe out all HP+          | deadliness >= 700 = "devastatingly"+          | deadliness >= 500 = "vehemently"+          | deadliness >= 400 = "forcefully"+          | deadliness >= 350 = "sturdily"+          | deadliness >= 300 = "accurately"+          | deadliness >= 20 = ""  -- common, terse case, between 2% and 30%+          | deadliness >= 10 = "cautiously"+          | deadliness >= 5 = "guardedly"+          | deadliness >= 3 = "hesitantly"+          | deadliness >= 2 = "clumsily"+          | deadliness >= 1 = "haltingly"+          | otherwise = "feebly"+        -- Here we take into account armor, so we look at @hurtMult@,+        -- so we finally convey the full info about effectiveness of the strike.+        blockHowWell  -- under some conditions, the message not shown at all+          | hurtMult > 90 = "incompetently"+          | hurtMult > 80 = "too late"+          | hurtMult > 70 = "too slowly"+          | hurtMult > 20 || nonPiercingDmg < 0 =+                            if | deadliness >= 2000 -> "marginally"+                               | deadliness >= 1000 -> "partially"+                               | deadliness >= 100 -> "partly"  -- common+                               | deadliness >= 50 -> "to an extent"+                               | deadliness >= 20 -> "to a large extent"+                               | deadliness >= 5 -> "for the major part"+                               | otherwise -> "for the most part"+          | hurtMult > 1 = if | actorWaits tb -> "doggedly"+                              | deadliness >= 50 -> "easily"  -- common+                              | deadliness >= 20 -> "effortlessly"+                              | deadliness >= 5 -> "nonchalantly"+                              | otherwise -> "bemusedly"+          | otherwise = "almost completely"+              -- a fraction gets through, but if fast missile, can be deadly+        avertVerb = if actorWaits tb then "avert it" else "ward it off"+        blockPhrase =+          let (subjectBlock, verbBlock) =+                if | not $ bproj sb ->+                     (tpronoun, if blockWithWeapon+                                then "parry"+                                else "block")+                   | tpronoun == "it"+                     || projectileHitsWeakly && tpronoun /= "you" ->+                     -- Avoid ambiguity.+                     (partActor tbUI, avertVerb)+                   | otherwise -> (tpronoun, avertVerb)+          in MU.SubjectVerbSg subjectBlock verbBlock+        surprisinglyGoodDefense = deadliness >= 20 && hurtMult <= 70+        surprisinglyBadDefense = deadliness < 20 && hurtMult > 70+        yetButAnd+          | surprisinglyGoodDefense = ", but"+          | surprisinglyBadDefense = ", yet"+          | otherwise = " and"  -- no surprises+        projectileHitsWeakly = bproj sb && deadliness < 20+        msgArmor = if not projectileHitsWeakly+                        -- ensures if attack msg terse, armor message+                        -- mentions object, so we know who is hit+                      && hurtMult > 90+                        -- at most minor armor relatively to skill of the hit+                      && (null condArmor || deadliness < 100)+                      || null blockWithWhat+                      || kineticDmg >= -1000  -- -1/1000 HP+                   then ""+                   else yetButAnd+                        <+> makePhrase ([blockPhrase, blockHowWell]+                                        ++ blockWithWhat)+        ps = (bpos tb, bpos sb)+        basicAnim+          | hurtMult > 70 = twirlSplash ps Color.BrRed Color.Red+          | hurtMult > 1 = if nonPiercingDmg >= 0  -- no extra anim+                           then blockHit ps Color.BrRed Color.Red+                           else blockMiss ps+          | otherwise = blockMiss ps+        targetIsFoe = bfid sb == side  -- no big news if others hit our foes+                      && isFoe (bfid tb) tfact side+        targetIsFriend = isFriend (bfid tb) tfact side+                           -- warning if anybody hits our friends+        msgClassMelee =+          if targetIsFriend then MsgMeleeNormalUs else MsgMeleeOthers+        msgClassRanged =+          if targetIsFriend then MsgRangedNormalUs else MsgRangedOthers+        animateAlive lid anim =+          if bhp tb > 0+          then animate lid anim+          else animate lid $ twirlSplashShort ps Color.BrRed Color.Red+        tutorialHintBenignFoe =+          when (bfid sb == side+                && not (actorCanMeleeToHarm actorMaxSkills target tb)) $+            tutorialHintMsgAdd CannotHarmYouInMelee+    -- The messages about parrying and immediately afterwards dying+    -- sound goofy, but there is no easy way to prevent that.+    -- And it's consistent.+    -- If/when death blow instead sets HP to 1 and only the next below 1,+    -- we can check here for HP==1; also perhaps actors with HP 1 should+    -- not be able to block.+    if | catch -> do  -- charge not needed when catching+         let msg = makeSentence+                     [MU.SubjectVerbSg spart "catch", tpart, "skillfully"]+         msgAdd MsgSpecialEvent msg+         when (bfid sb == side) $+           tutorialHintMsgAdd CaughtProjectile+         animate (blid tb) $ blockHit ps Color.BrGreen Color.Green+       | not (hasCharge localTime kitWeapon) -> do+         -- Can easily happen with a thrown discharged item.+         -- Much less plausible with a wielded weapon.+         -- Theoretically possible if the weapon not identified+         -- (then timeout is a mean estimate), but they usually should be,+         -- even in foes' possession.+         let msg = if bproj sb+                   then makePhrase+                          [MU.Capitalize $ MU.SubjectVerbSg spart "connect"]+                        <> ", but it may be completely discharged."+                   else makePhrase+                          ([ MU.Capitalize $ MU.SubjectVerbSg spart "try"+                           , "to"+                           , verb+                           , tpart ]+                           ++ weaponNameWith)+                        <> if null weaponNameWith+                           then ", but there are no charges left."+                           else ", but it may be not readied yet."+         msgAdd MsgSpecialEvent msg  -- and no animation+       | bproj sb && bproj tb -> do  -- server sends unless both are blasts+         -- Short message.+         msgAdd MsgSpecialEvent $+           makeSentence [MU.SubjectVerbSg spart "intercept", tpart]+         -- Basic non-bloody animation regardless of stats.+         animateAlive (blid tb) $ blockHit ps Color.BrBlue Color.Blue+       | kineticDmg >= -1000  -- -1/1000 HP+         -- We ignore nested effects, because they are, in general, avoidable.+         && nonPiercingDmg >= 0 -> do+         let adverb | itemSuspect itemFullWeapon && bfid sb == side =+                        "tentatively"  -- we didn't identify the weapon before+                    | bproj sb = "lightly"+                    | otherwise = "delicately"+             msg = makeSentence $+               [MU.SubjectVerbSg spart verb, tpart, adverb]+               ++ if bproj sb then [] else weaponNameWith+         msgAdd msgClassMelee msg  -- too common for color+         when (bfid sb == side || bfid tb == side) $+           tutorialHintMsgAdd HitsWithNoDirectDamage+         animate (blid tb) $ subtleHit ps+       | bproj sb -> do  -- more terse than melee, because sometimes very spammy+         let msgRangedPowerful | targetIsFoe = MsgRangedMightyWe+                               | targetIsFriend = MsgRangedMightyUs+                               | otherwise = msgClassRanged+             (attackParts, msgRanged)+               | projectileHitsWeakly =+                 ( [MU.SubjectVerbSg spart "connect"]  -- weak, so terse+                 , msgClassRanged )+               | deadliness >= 300 =+                 ( [MU.SubjectVerbSg spart verb, tpart, "powerfully"]+                 , if targetIsFriend || deadliness >= 700+                   then msgRangedPowerful+                   else msgClassRanged )+               | otherwise =+                 ( [MU.SubjectVerbSg spart verb, tpart]  -- strong, for a proj+                 , msgClassRanged )+         msgAdd msgRanged $ makePhrase [MU.Capitalize $ MU.Phrase attackParts]+                            <> msgArmor <> "."+         tutorialHintBenignFoe+         animateAlive (blid tb) basicAnim+       | bproj tb -> do  -- much less emotion and the victim not active.+         let attackParts =+               [MU.SubjectVerbSg spart verb, tpart] ++ weaponNameWith+         msgAdd MsgMeleeOthers $ makeSentence attackParts+         animateAlive (blid tb) basicAnim+       | otherwise -> do  -- ordinary melee+         let msgMeleeInteresting | targetIsFoe = MsgMeleeComplexWe+                                 | targetIsFriend = MsgMeleeComplexUs+                                 | otherwise = msgClassMelee+             msgMeleePowerful | targetIsFoe = MsgMeleeMightyWe+                              | targetIsFriend = MsgMeleeMightyUs+                              | otherwise = msgClassMelee+             attackParts =+               [MU.SubjectVerbSg spart verb, sleepy, tpart, strongly]+               ++ weaponNameWith+             (tmpInfluenceBlurb, msgClassInfluence) =+               if null condArmor || T.null msgArmor+               then ("", msgClassMelee)+               else+                 let (armor, (_, itemFullArmor)) =+                       maximumBy (comparing $ abs . fst) condArmor+                     (object1, object2) =+                       partItemShortest rwidth (bfid tb) factionD localTime+                                        itemFullArmor quantSingle+                     name = makePhrase [object1, object2]+                     msgText =+                       if hurtMult > 70+                       then (if armor <= -15+                             then ", due to being"+                             else assert (armor >= 15) ", regardless of being")+                            <+> name+                       else (if armor >= 15+                             then ", thanks to being"+                             else assert (armor <= -15) ", despite being")+                            <+> name+                 in (msgText, msgMeleeInteresting)+             msgClass = if targetIsFriend && deadliness >= 300+                           || deadliness >= 2000+                        then msgMeleePowerful+                        else msgClassInfluence+         msgAdd msgClass $ makePhrase [MU.Capitalize $ MU.Phrase attackParts]+                           <> msgArmor <> tmpInfluenceBlurb <> "."+         tutorialHintBenignFoe+         animateAlive (blid tb) basicAnim
+ engine-src/Game/LambdaHack/Client/UI/Watch/WatchUpdAtomicM.hs view
@@ -0,0 +1,1096 @@+-- | Display atomic update commands received by the client.+module Game.LambdaHack.Client.UI.Watch.WatchUpdAtomicM+  ( watchRespUpdAtomicUI+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , assignItemRole, Threat, createActorUI, destroyActorUI, spotItemBag+  , recordItemLid, moveActor, displaceActorUI, moveItemUI+  , discover, ppHearMsg, ppHearDistanceAdjective, ppHearDistanceAdverb+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent (threadDelay)+import qualified Data.Char as Char+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import           GHC.Exts (inline)+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Animation+import           Game.LambdaHack.Client.UI.Content.Screen+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.DrawM+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.ItemDescription+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Client.UI.TutorialHints (TutorialHints (..))+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Client.UI.Watch.WatchCommonM+import           Game.LambdaHack.Client.UI.Watch.WatchQuitM+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.CaveKind (cdesc)+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.ModeKind as MK+import           Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Content.TileKind as TK+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.Flavour++-- | Visualize atomic updates sent to the client. This is done+-- in the global state after the command is executed and after+-- the client state is modified by the command.+-- Doesn't modify client state (except a few fields), but only client+-- session (e.g., by displaying messages). This is enforced by types.+watchRespUpdAtomicUI :: MonadClientUI m => UpdAtomic -> m ()+{-# INLINE watchRespUpdAtomicUI #-}+watchRespUpdAtomicUI cmd = case cmd of+  -- Create/destroy actors and items.+  UpdRegisterItems{} -> return ()+  UpdCreateActor aid body _ -> createActorUI True aid body+  UpdDestroyActor aid body _ -> destroyActorUI True aid body+  UpdCreateItem verbose iid _ kit@(kAdd, _) c -> do+    recordItemLid iid c+    assignItemRole c iid+    when verbose $ case c of+      CActor aid store -> do+        b <- getsState $ getActorBody aid+        case store of+          _ | bproj b ->+            itemVerbMU MsgItemCreation iid kit "appear" c+          COrgan -> do+            localTime <- getsState $ getLocalTime (blid b)+            arItem <- getsState $ aspectRecordFromIid iid+            if | IA.checkFlag Ability.Blast arItem -> return ()+               | IA.checkFlag Ability.Condition arItem -> do+                 side <- getsClient sside+                 discoBenefit <- getsClient sdiscoBenefit+                 bag <- getsState $ getContainerBag c+                 itemKind <- getsState $ getIidKind iid+                 let more = case EM.lookup iid bag of+                       Just (kTotal, _) | kTotal /= kAdd -> Just kTotal+                       _ -> Nothing+                     verbShow = MU.Text $+                       "become"+                       <+> case kit of+                         (1, _ : _) -> "somewhat"+                         (1, []) | isNothing more -> ""+                         _ | isNothing more -> "many-fold"+                         _ -> "additionally"+                     verbSave = MU.Text $+                       "become"+                       <+> case kit of+                         (1, t:_) ->  -- only exceptionally not singleton list+                                      -- or even more than one copy total+                           let total = deltaOfItemTimer localTime t+                           in timeDeltaInSecondsText total+                         (1, []) | isNothing more -> ""+                         (k, _) ->  -- usually the list empty; ignore anyway+                           (if isJust more then "additionally" else "")+                           <+> tshow k <> "-fold"+                           <+> case more of+                                 Nothing -> ""+                                 Just kTotal ->+                                   "(total:" <+> tshow kTotal <> "-fold)"+                     good = benInEqp (discoBenefit EM.! iid)+                     msgClass = case lookup IK.S_ASLEEP $ IK.ifreq itemKind of+                       Just n | n > 0 -> MsgStatusSleep+                       _ -> if | bfid b /= side -> MsgStatusOthers+                               | good -> MsgStatusGoodUs+                               | otherwise -> MsgStatusBadUs+                 -- This describes all such items already among organs,+                 -- which is useful, because it shows "charging".+                 itemAidDistinctMU msgClass aid verbShow verbSave iid+                 when (bfid b == side && not good) $+                   -- Others get conditions too often and good ones are not+                   -- dire enough and also too common.+                   tutorialHintMsgAdd TemporaryConditions+               | otherwise -> do+                 wown <- ppContainerWownW partActorLeader True c+                 itemVerbMU MsgItemCreation iid kit+                            (MU.Text $ makePhrase $ "grow" : wown) c+          _ -> do+            wown <- ppContainerWownW partActorLeader True c+            itemVerbMU MsgItemCreation iid kit+                       (MU.Text $ makePhrase $ "appear" : wown) c+      CEmbed{} -> return ()  -- not visible so can't delay even if important+      CFloor lid _ -> do+        factionD <- getsState sfactionD+        itemVerbMU MsgItemCreation iid kit+                   (MU.Text $ "appear" <+> ppContainer factionD c) c+        markDisplayNeeded lid+      CTrunk{} -> return ()+  UpdDestroyItem verbose iid _ kit c ->+    when verbose $ case c of+      CActor aid _  -> do+        b <- getsState $ getActorBody aid+        if bproj b then+          itemVerbMUShort MsgItemRuination iid kit "break" c+        else do+          ownW <- ppContainerWownW partActorLeader False c+          let verb = MU.Text $ makePhrase $ "vanish from" : ownW+          itemVerbMUShort MsgItemRuination iid kit verb c+      CEmbed{} -> return ()  -- not visible so can't delay even if important+      CFloor lid _ -> do+        factionD <- getsState sfactionD+        itemVerbMUShort MsgItemRuination iid kit+                        (MU.Text $ "break" <+> ppContainer factionD c) c+        markDisplayNeeded lid+      CTrunk{} -> return ()+  UpdSpotActor aid body -> createActorUI False aid body+  UpdLoseActor aid body -> destroyActorUI False aid body+  UpdSpotItem verbose iid kit c -> spotItemBag verbose c $ EM.singleton iid kit+  UpdLoseItem True iid kit c@(CActor aid _) -> do+    b <- getsState $ getActorBody aid+    when (not (bproj b) && bhp b > 0) $ do  -- don't spam+      ownW <- ppContainerWownW partActorLeader False c+      let verb = MU.Text $ makePhrase $ "be removed from" : ownW+      itemVerbMUShort MsgItemMovement iid kit verb c+  UpdLoseItem{} -> return ()+  UpdSpotItemBag verbose c bag -> spotItemBag verbose c bag+  UpdLoseItemBag{} -> return ()  -- rarely interesting and can be very long+  -- Move actors and items.+  UpdMoveActor aid source target -> moveActor aid source target+  UpdWaitActor aid WSleep _ -> do+    aidVerbMU MsgStatusWakeup aid "wake up"+    tutorialHintMsgAdd WokenUpActors+  UpdWaitActor aid WWake _ -> do+    side <- getsClient sside+    b <- getsState $ getActorBody aid+    unless (bfid b == side) $+      tutorialHintMsgAdd AvoidWalkingEnemies+  UpdWaitActor{} -> return ()  -- falling asleep handled uniformly elsewhere+  UpdDisplaceActor source target -> displaceActorUI source target+  UpdMoveItem iid k aid c1 c2 -> moveItemUI iid k aid c1 c2+  -- Change actor attributes.+  UpdRefillHP _ 0 -> return ()+  UpdRefillHP aid hpDelta -> do+    let coarseDelta = abs hpDelta `div` oneM+        tDelta = if coarseDelta == 0+                 then if hpDelta > 0 then "a little" else "a fraction of an HP"+                 else tshow coarseDelta <+> "HP"+    b <- getsState $ getActorBody aid+    unless (bproj b) $+      aidVerbMU MsgNumericReport aid $ MU.Text+                ((if hpDelta > 0 then "heal" else "lose") <+> tDelta)+    arena <- getArenaUI+    side <- getsClient sside+    if | bproj b && (EM.null (beqp b) || isNothing (btrajectory b)) ->+           return ()  -- ignore caught proj or one hitting a wall+       | bhp b <= 0 && hpDelta < 0+         && (bfid b == side && not (bproj b) || arena == blid b) -> do+         let (firstFall, hurtExtra) = case (bfid b == side, bproj b) of+               (True, True) -> ("drop down", "tumble down")+               (True, False) -> ("fall down", "suffer woeful mutilation")+               (False, True) -> ("plummet", "crash")+               (False, False) -> ("collapse", "be reduced to a bloody pulp")+             verbDie = if alreadyDeadBefore then hurtExtra else firstFall+             -- Rarely, this is wrong, because 2 other actors hit the victim+             -- at exactly the same time. No big problem. Doubled "dies"+             -- messages appears instead of "dies; is mutilated".+             alreadyDeadBefore = bhp b - hpDelta <= 0+         tfact <- getsState $ (EM.! bfid b) . sfactionD+         bUI <- getsSession $ getActorUI aid+         subjectRaw <- partActorLeader aid+         let subject = if alreadyDeadBefore || subjectRaw == "you"+                       then subjectRaw+                       else partActor bUI  -- avoid "fallen"+             msgDie = makeSentence [MU.SubjectVerbSg subject verbDie]+             targetIsFoe = isFoe (bfid b) tfact side+             targetIsFriend = isFriend (bfid b) tfact side+             msgClass | bproj b = MsgDeathBoring+                      | targetIsFoe = MsgDeathVictory+                      | targetIsFriend = MsgDeathDeafeat+                      | otherwise = MsgDeathBoring+         if | bproj b -> msgAdd msgClass msgDie+            | bfid b == side -> do+              msgLnAdd msgClass $ msgDie <+> "Alas!"+              displayMore ColorBW ""+            | otherwise -> msgLnAdd msgClass msgDie+         -- We show death anims only if not dead already before this refill.+         let deathAct = if bfid b == side+                        then deathBody (bpos b)+                        else shortDeathBody (bpos b)+         unless (bproj b || alreadyDeadBefore) $ animate (blid b) deathAct+       | otherwise -> do+         when (hpDelta >= bhp b && bhp b > 0) $+           aidVerbMU MsgActionWarning aid "return from the brink of death"+         mleader <- getsClient sleader+         when (Just aid == mleader) $ do+           actorMaxSk <- getsState $ getActorMaxSkills aid+           -- Regenerating actors never stop gaining HP, so we need to stop+           -- reporting it after they reach full HP for the first time.+           -- Also, no spam for non-leaders.+           when (bhp b >= xM (Ability.getSk Ability.SkMaxHP actorMaxSk)+                 && bhp b - hpDelta < xM (Ability.getSk Ability.SkMaxHP+                                                  actorMaxSk)) $+             msgAdd MsgSpecialEvent "You recover your health fully. Any further gains will be transient."+         when (bfid b == side && not (bproj b)) $ do+           when (abs hpDelta >= oneM) $ markDisplayNeeded (blid b)+           when (hpDelta < 0) $ do+             when (hpDelta <= xM (-3)) $ tutorialHintMsgAdd AlotOfDamageFromOneSource+             sUIOptions <- getsSession sUIOptions+             currentWarning <-+               getsState $ checkWarningHP sUIOptions aid (bhp b)+             when currentWarning $ do+               previousWarning <-+                 getsState $ checkWarningHP sUIOptions aid (bhp b - hpDelta)+               unless previousWarning $+                 aidVerbMU MsgRiskOfDeath aid+                           "be down to a dangerous health level"+  UpdRefillCalm _ 0 -> return ()+  UpdRefillCalm aid calmDelta -> do+    side <- getsClient sside+    b <- getsState $ getActorBody aid+    when (bfid b == side && not (bproj b)) $ do+      if | calmDelta > 0 -> do  -- regeneration or effect+           mleader <- getsClient sleader+           when (Just aid == mleader) $ do+             actorMaxSk <- getsState $ getActorMaxSkills aid+             let bPrev = b {bcalm = bcalm b - calmDelta}+             when (calmEnough b actorMaxSk+                   && not (calmEnough bPrev actorMaxSk)) $+               msgAdd MsgSpecialEvent "You are again calm enough to manage your equipment outfit."+           -- If the leader regenerates Calm more often than once per+           -- standard game turn, this will not be reflected, for smoother+           -- and faster display. However, every halt for keypress+           -- shows Calm, so this only matters for macros, where speed is good.+           when (abs calmDelta > oneM) $ markDisplayNeeded (blid b)+         | calmDelta == minusM1 -> do+           fact <- getsState $ (EM.! side) . sfactionD+           s <- getState+           let closeFoe (!p, aid2) =  -- mimics isHeardFoe+                 let b2 = getActorBody aid2 s+                 in inline chessDist p (bpos b) <= 3+                    && not (actorWaitsOrSleeps b2)  -- uncommon+                    && inline isFoe side fact (bfid b2)  -- costly+               anyCloseFoes = any closeFoe $ EM.assocs $ lbig+                                           $ sdungeon s EM.! blid b+           unless anyCloseFoes $ do  -- obvious where the feeling comes from+             duplicated <- aidVerbDuplicateMU MsgHeardNearby aid+                                              "hear something"+             unless duplicated stopPlayBack+         | otherwise ->  -- low deltas from hits; displayed elsewhere+           return ()+      when (calmDelta < 0) $ do+        sUIOptions <- getsSession sUIOptions+        currentWarning <-+          getsState $ checkWarningCalm sUIOptions aid (bcalm b)+        when currentWarning $ do+          previousWarning <-+            getsState $ checkWarningCalm sUIOptions aid (bcalm b - calmDelta)+          unless previousWarning $+            -- This messages is not shown if impression happens after+            -- Calm is low enough. However, this is rare and HUD shows the red.+            aidVerbMU MsgRiskOfDeath aid+                      "have grown agitated and impressed enough to be in danger of defecting"+  UpdTrajectory _ _ mt ->  -- if projectile dies just after, force one frame+    when (isNothing mt) $ pushFrame False+  -- Change faction attributes.+  UpdQuitFaction fid _ toSt manalytics -> quitFactionUI fid toSt manalytics+  UpdSpotStashFaction verbose fid lid pos -> do+    side <- getsClient sside+    when verbose $ do+      if fid == side then+        msgLnAdd MsgFactionIntel+                 "You set up the shared inventory stash of your team."+      else do+        fact <- getsState $ (EM.! fid) . sfactionD+        let fidName = MU.Text $ gname fact+        msgAdd MsgFactionIntel $+          makeSentence [ "you have found the current"+                       , MU.WownW fidName "hoard location" ]+    unless (fid == side) $+      animate lid $ actorX pos+  UpdLoseStashFaction verbose fid lid pos -> do+    when verbose $ do+      side <- getsClient sside+      if fid == side then+        msgAdd MsgFactionIntel+               "You've lost access to your shared inventory stash!"+      else do+        fact <- getsState $ (EM.! fid) . sfactionD+        let fidName = MU.Text $ gname fact+        msgAdd MsgFactionIntel $+          makeSentence [fidName, "no longer control their hoard"]+    animate lid $ vanish pos+  UpdLeadFaction fid (Just source) mtgt@(Just target) -> do+    mleader <- getsClient sleader+    when (mtgt /= mleader) $ do+      fact <- getsState $ (EM.! fid) . sfactionD+      lidV <- viewedLevelUI+      when (gunderAI fact) $ markDisplayNeeded lidV+      -- This faction can't run with multiple actors, so this is not+      -- a leader change while running, but rather server changing+      -- their leader, which the player should be alerted to.+      when (noRunWithMulti fact) stopPlayBack+      actorD <- getsState sactorD+      case EM.lookup source actorD of+        Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do+          -- Regardless who the leader is, give proper names here, not 'you'.+          sbUI <- getsSession $ getActorUI source+          tbUI <- getsSession $ getActorUI target+          let subject = partActor tbUI+              object  = partActor sbUI+          msgAdd MsgPointmanSwap $+            makeSentence [ MU.SubjectVerbSg subject "take command"+                         , "from", object ]+        _ -> return ()+      lookAtMove target+  UpdLeadFaction _ Nothing mtgt@(Just target) -> do+    mleader <- getsClient sleader+    when (mtgt /= mleader) $+      lookAtMove target+  UpdLeadFaction{} -> return ()+  UpdDiplFaction fid1 fid2 _ toDipl -> do+    name1 <- getsState $ gname . (EM.! fid1) . sfactionD+    name2 <- getsState $ gname . (EM.! fid2) . sfactionD+    msgAdd MsgFactionIntel $+      name1 <+> "and" <+> name2 <+> "are now" <+> tshowDiplomacy toDipl <> "."+  UpdDoctrineFaction{} -> return ()+  UpdAutoFaction fid b -> do+    side <- getsClient sside+    lidV <- viewedLevelUI+    markDisplayNeeded lidV+    when (fid == side) $ do+      unless b $+        -- Clear macros and invoke a special main menu entrance macro+        -- that sets @swasAutomated@, preparing for AI control at exit.+        modifySession $ \sess ->+          sess { smacroFrame =+                   emptyMacroFrame {keyPending = KeyMacro [K.controlEscKM]}+               , smacroStack = [] }+      setFrontAutoYes b  -- now can start/stop auto-accepting prompts+  UpdRecordKill{} -> return ()+  -- Alter map.+  UpdAlterTile lid p fromTile toTile -> do+    COps{cotile} <- getsState scops+    markDisplayNeeded lid+    let feats = TK.tfeature $ okind cotile fromTile+        toAlter feat =+          case feat of+            TK.OpenTo tgroup -> Just tgroup+            TK.CloseTo tgroup -> Just tgroup+            TK.ChangeTo tgroup -> Just tgroup+            TK.OpenWith _ _ tgroup -> Just tgroup+            TK.CloseWith _ _ tgroup -> Just tgroup+            TK.ChangeWith _ _ tgroup -> Just tgroup+            _ -> Nothing+        groupsToAlterTo = mapMaybe toAlter feats+        freq = map fst $ filter (\(_, q) -> q > 0)+               $ TK.tfreq $ okind cotile toTile+        unexpected = null $ intersect freq groupsToAlterTo+    mactorAtPos <- getsState $ posToBig p lid+    mleader <- getsClient sleader+    when (unexpected || isJust mactorAtPos && mactorAtPos /= mleader) $ do+      -- Faction notices @fromTile@ can't be altered into @toTIle@,+      -- which is uncanny, so we produce a message.+      -- This happens when the player missed an earlier search of the tile+      -- performed by another faction.+      let subject = ""  -- a hack, because we don't handle adverbs well+          verb = "turn into"+          msg = makeSentence $+            [ "the", MU.Text $ TK.tname $ okind cotile fromTile+            , "at position", MU.Text $ tshow p ]+            ++ ["suddenly" | unexpected]  -- adverb+            ++ [ MU.SubjectVerbSg subject verb+               , MU.AW $ MU.Text $ TK.tname $ okind cotile toTile ]+      msgAdd (if unexpected then MsgSpecialEvent else MsgNeutralEvent) msg+  UpdAlterExplorable lid _ -> markDisplayNeeded lid+  UpdAlterGold{} -> return ()  -- not displayed on HUD+  UpdSearchTile aid _p toTile -> do+    COps{cotile} <- getsState scops+    subject <- partActorLeader aid+    let fromTile = fromMaybe (error $ show toTile) $ Tile.hideAs cotile toTile+        subject2 = MU.Text $ TK.tname $ okind cotile fromTile+        object = MU.Text $ TK.tname $ okind cotile toTile+    let msg = makeSentence [ MU.SubjectVerbSg subject "reveal"+                           , "that the"+                           , MU.SubjectVerbSg subject2 "be"+                           , MU.AW object ]+    unless (subject2 == object) $ do+      msgAdd MsgTerrainReveal msg+      tutorialHintMsgAdd TerrainNotFullyKnown+  UpdHideTile{} -> return ()+  UpdSpotTile{} -> return ()+  UpdLoseTile{} -> return ()+  UpdSpotEntry{} -> return ()+  UpdLoseEntry{} -> return ()+  UpdAlterSmell{} -> return ()+  UpdSpotSmell{} -> return ()+  UpdLoseSmell{} -> return ()+  -- Assorted.+  UpdTimeItem{} -> return ()+  UpdAgeGame{} -> do+    sdisplayNeeded <- getsSession sdisplayNeeded+    sturnDisplayed <- getsSession sturnDisplayed+    time <- getsState stime+    let clipN = time `timeFit` timeClip+        clipMod = clipN `mod` clipsInTurn+        turnPing = clipMod == 0  -- e.g., to see resting counter+    if | sdisplayNeeded -> pushFrame True+           -- adds delay, because it's not an extra animation-like frame,+           -- but showing some real information accumulated up to this point+       | turnPing && not sturnDisplayed -> pushFrame False+       | otherwise -> return ()+    when turnPing $+      modifySession $ \sess -> sess {sturnDisplayed = False}+  UpdUnAgeGame{} -> return ()+  UpdDiscover c iid _ _ -> discover c iid+  UpdCover{} -> return ()  -- don't spam when doing undo+  UpdDiscoverKind{} -> return ()  -- don't spam when server tweaks stuff+  UpdCoverKind{} -> return ()  -- don't spam when doing undo+  UpdDiscoverAspect{} -> return ()  -- don't spam when server tweaks stuff+  UpdCoverAspect{} -> return ()  -- don't spam when doing undo+  UpdDiscoverServer{} -> error "server command leaked to client"+  UpdCoverServer{} -> error "server command leaked to client"+  UpdPerception{} -> return ()+  UpdRestart fid _ _ _ _ srandom -> do+    cops@COps{cocave, comode, corule} <- getsState scops+    oldSess <- getSession+    snxtChal <- getsClient snxtChal+    noConfirmsGame <- isNoConfirmsGame+    let uiOptions = sUIOptions oldSess+        f !acc _p !i _a = i : acc+        modes = zip [0..] $ ofoldlGroup' comode CAMPAIGN_SCENARIO f []+        g :: (Int, ContentId ModeKind) -> Int+        g (_, mode) = case EM.lookup mode (svictories oldSess) of+          Nothing -> 0+          Just cm -> fromMaybe 0 (M.lookup snxtChal cm)+        (snxtScenario, _) = minimumBy (comparing g) modes+        nxtGameTutorial = MK.mtutorial $ snd $ nxtGameMode cops snxtScenario+    putSession $+      (emptySessionUI uiOptions)+        { schanF = schanF oldSess+        , sccui = sccui oldSess+        , shistory = shistory oldSess+        , svictories = svictories oldSess+        , scampings = scampings oldSess+        , srestarts = srestarts oldSess+        , smarkVision = smarkVision oldSess+        , smarkSmell = smarkSmell oldSess+        , snxtScenario+        , scurTutorial = noConfirmsGame || snxtTutorial oldSess+            -- make sure a newbie interrupting a screensaver has ample help+        , snxtTutorial = nxtGameTutorial+        , soverrideTut = soverrideTut oldSess+        , sstart = sstart oldSess+        , sgstart = sgstart oldSess+        , sallTime = sallTime oldSess+        , snframes = snframes oldSess+        , sallNframes = sallNframes oldSess+        , srandomUI = srandom+        }+    when (sstart oldSess == 0) resetSessionStart+    when (lengthHistory (shistory oldSess) == 0) $ do+      -- Generate initial history. Only for UI clients.+      shistory <- defaultHistory+      modifySession $ \sess -> sess {shistory}+      let title = T.pack $ rtitle corule+      msgAdd MsgBookKeeping $ "Welcome to" <+> title <> "!"+    recordHistory  -- to ensure EOL even at creation of history+    lid <- getArenaUI+    lvl <- getLevel lid+    gameMode <- getGameMode+    curChal <- getsClient scurChal+    fact <- getsState $ (EM.! fid) . sfactionD+    let loneMode = case ginitial fact of+          [] -> True+          [(_, 1, _)] -> True+          _ -> False+    msgAdd MsgBookKeeping "-------------------------------------------------"+    recordHistory+    msgAdd MsgPromptGeneric+           "A grand story starts right here! (Press '?' for mode description and help.)"+    if lengthHistory (shistory oldSess) > 1+      then fadeOutOrIn False+      else pushReportFrame  -- show anything ASAP+    msgAdd MsgActionWarning+           ("New game started in" <+> mname gameMode <+> "mode.")+    let desc = cdesc $ okind cocave $ lkind lvl+    unless (T.null desc) $ do+      msgLnAdd MsgBackdropFocus "You take in your surroundings."+      msgAdd MsgBackdropInfo desc+    -- We can fool the player only once (per scenario), but let's not do it+    -- in the same way each time. TODO: PCG+    blurb <- rndToActionUI $ oneOf+      [ "You think you saw movement."+      , "Something catches your peripherial vision."+      , "You think you felt a tremor under your feet."+      , "A whiff of chilly air passes around you."+      , "You notice a draft just when it dies down."+      , "The ground nearby is stained along some faint lines."+      , "Scarce black motes slowly settle on the ground."+      , "The ground in the immediate area is empty, as if just swiped."+      ]+    msgLnAdd MsgBadMiscEvent blurb  -- being here is a bad turn of events+    when (cwolf curChal && not loneMode) $+      msgAdd MsgActionWarning "Being a lone wolf, you begin without companions."+    setFrontAutoYes $ gunderAI fact+    -- Forget the furious keypresses when dying in the previous game.+    resetPressedKeys+  UpdRestartServer{} -> return ()+  UpdResume fid _ -> do+    COps{cocave} <- getsState scops+    resetSessionStart+    fact <- getsState $ (EM.! fid) . sfactionD+    setFrontAutoYes $ gunderAI fact+    unless (gunderAI fact) $ do+      lid <- getArenaUI+      lvl <- getLevel lid+      gameMode <- getGameMode+      msgAdd MsgPromptGeneric+             "Welcome back! (Press '?' for mode description and help.)"+      pushReportFrame  -- show anything ASAP+      msgAdd MsgActionAlert $ "Continuing" <+> mname gameMode <+> "mode."+      let desc = cdesc $ okind cocave $ lkind lvl+      unless (T.null desc) $ do+        msgLnAdd MsgPromptFocus "You remember your surroundings."+        msgAdd MsgPromptGeneric desc+  UpdResumeServer{} -> return ()+  UpdKillExit{} -> do+#ifdef USE_JSFILE+      -- Some browsers seem to trash Local Storage when page reloaded or closed+      -- or the browser closed, while they still internally finish the saving+      -- in the background, so wait 2s. If the exit is without a save,+      -- the wait is spurious, but it's not supposed to be common.+      -- TODO: replace the @liftIO@ with a @MonadClientUI@ delay function.+    liftIO $ threadDelay 2000000+#else+    liftIO $ threadDelay 200000+#endif+    -- The prompt is necessary to force frontend to show this before exiting.+    void $ displayMore ColorBW "Done."  -- in case it follows "Saving..."+    side <- getsClient sside+    debugPossiblyPrintUI $ "Client" <+> tshow side <+> "closing frontend."+    frontendShutdown+    debugPossiblyPrintUI $ "Client" <+> tshow side <+> "closed frontend."+  UpdWriteSave -> msgAdd MsgInnerWorkSpam "Saving backup."+  UpdHearFid _ distance hearMsg -> do+    mleader <- getsClient sleader+    case mleader of+      Just{} -> return ()  -- will flush messages when leader moves+      Nothing -> do+        lidV <- viewedLevelUI+        markDisplayNeeded lidV+        recordHistory+    msg <- ppHearMsg distance hearMsg+    let msgClass = case distance of+          Nothing -> MsgHeardOutside+          Just 0 -> MsgHeardNearby+          Just _ -> MsgHeardFaraway+    msgAdd msgClass msg+    case hearMsg of+      HearUpd UpdDestroyActor{} ->+        tutorialHintMsgAdd OutOfSightEvents+      HearTaunt{} -> do+        globalTime <- getsState stime+        when (globalTime > timeTurn) $  -- avoid too many hints at the start+          tutorialHintMsgAdd HearingRadius+      _ -> return ()+  UpdMuteMessages _ smuteMessages ->+    modifySession $ \sess -> sess {smuteMessages}++assignItemRole :: MonadClientUI m => Container -> ItemId -> m ()+assignItemRole c iid = do+  arItem <- getsState $ aspectRecordFromIid iid+  let assignSingleRole lore = do+        ItemRoles itemRoles <- getsSession sroles+        let itemRole = itemRoles EM.! lore+        unless (iid `ES.member` itemRole) $ do+          let newRoles = ItemRoles $ EM.adjust (ES.insert iid) lore itemRoles+          modifySession $ \sess -> sess {sroles = newRoles}+      slore = IA.loreFromContainer arItem c+  assignSingleRole slore+  when (slore `elem` [SOrgan, STrunk, SCondition]) $+    assignSingleRole SBody++data Threat =+    ThreatNone+  | ThreatUnarmed+  | ThreatArmed+  | ThreatAnotherUnarmed+  | ThreatAnotherArmed+  deriving Eq++createActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m ()+createActorUI born aid body = do+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  side <- getsClient sside+  factionD <- getsState sfactionD+  let fact = factionD EM.! bfid body+  localTime <- getsState $ getLocalTime $ blid body+  itemFull@ItemFull{itemBase, itemKind} <- getsState $ itemToFull (btrunk body)+  actorUI <- getsSession sactorUI+  let arItem = aspectRecordFull itemFull+  unless (aid `EM.member` actorUI) $ do+    UIOptions{uHeroNames} <- getsSession sUIOptions+    let baseColor = flavourToColor $ jflavour itemBase+        basePronoun | not (bproj body)+                      && IK.isymbol itemKind == '@'+                      && fhasGender (gkind fact) = "he"+                    | otherwise = "it"+        nameFromNumber fn k = if k == 0+                              then makePhrase [MU.Ws $ MU.Text fn, "Captain"]+                              else fn <+> tshow k+        heroNamePronoun k =+          if gcolor fact /= Color.BrWhite+          then (nameFromNumber (fname $ gkind fact) k, "he")+          else fromMaybe (nameFromNumber (fname $ gkind fact) k, "he")+               $ lookup k uHeroNames+        (n, bsymbol) =+          if | bproj body -> (0, if IA.checkFlag Ability.Blast arItem+                                 then IK.isymbol itemKind+                                 else '*')+             | baseColor /= Color.BrWhite -> (0, IK.isymbol itemKind)+             | otherwise -> case bnumber body of+                 Nothing ->+                   error $ "numbered actor without server-assigned number"+                           `showFailure` (aid, body)+                 Just bn -> (bn, if 0 < bn && bn < 10+                                 then Char.intToDigit bn+                                 else '@')+        (object1, object2) =+          partItemShortest rwidth (bfid body) factionD localTime+                           itemFull quantSingle+        (bname, bpronoun) =+          if | bproj body ->+               let adj = case btrajectory body of+                     Just (tra, _) | length tra < 5 -> "falling"+                     _ -> "flying"+               in (makePhrase [adj, object1, object2], basePronoun)+             | baseColor /= Color.BrWhite ->+               (makePhrase [object1, object2], basePronoun)+             | otherwise -> heroNamePronoun n+        bcolor | bproj body = if IA.checkFlag Ability.Blast arItem+                              then baseColor+                              else Color.BrWhite+               | baseColor == Color.BrWhite = gcolor fact+               | otherwise = baseColor+        bUI = ActorUI{..}+    modifySession $ \sess ->+      sess {sactorUI = EM.insert aid bUI actorUI}+  mapM_ (\(iid, store) -> do+           let c = if not (bproj body) && iid == btrunk body+                   then CTrunk (bfid body) (blid body) (bpos body)+                   else CActor aid store+           assignItemRole c iid+           recordItemLid iid c)+        ((btrunk body, CEqp)  -- store will be overwritten, unless projectile+         : filter ((/= btrunk body) . fst) (getCarriedIidCStore body))+  if | bproj body -> do+       when (bfid body /= side)+         stopPlayBack+       pushFrame False  -- make sure first (seen (again)) position displayed+     | bfid body == side -> do+       let upd = ES.insert aid+       modifySession $ \sess -> sess {sselected = upd $ sselected sess}+       unless (EM.null actorUI) $ do  -- don't announce the very first party member+         when born $ do+           let verb = "join you"+           aidVerbMU MsgSpottedActor aid verb+           tutorialHintMsgAdd SwitchTeammate+           animate (blid body) $ actorX (bpos body)+     | otherwise -> do+       -- Don't spam if the actor was already visible+       -- (but, e.g., on a tile that is invisible this turn+       -- (in that case move is broken down to lose+spot)+       -- or on a distant tile, via teleport while the observer+       -- teleported, too).+       lastLost <- getsSession slastLost+       if ES.member aid lastLost+       then markDisplayNeeded (blid body)+       else do+         stopPlayBack+         let verb = if born then "appear suddenly" else "be spotted"+         threat <-+           if isFoe (bfid body) fact side then do+             -- Aim even if nobody can shoot at the enemy.+             -- Let's home in on him and then we can aim or melee.+             -- We set permit to False, because it's technically+             -- very hard to check aimability here, because we are+             -- in-between turns and, e.g., leader's move has not yet+             -- been taken into account.+             xhair <- getsSession sxhair+             case xhair of+               Just (TVector _) -> return ()  -- explicitly set; keep it+               _ -> modifySession $ \sess ->+                      sess { sxhair = Just $ TEnemy aid+                           , sitemSel = Nothing } -- reset flinging totally+             foes <- getsState $ foeRegularList side (blid body)+             itemsSize <- getsState $ guardItemSize body+             if length foes <= 1 then+               if itemsSize == 0 then do+                 msgAdd MsgSpottedThreat "You are not alone!"+                 return ThreatUnarmed+               else do+                 msgAdd MsgSpottedThreat "Armed intrusion ahead!"+                 return ThreatArmed+             else+               if itemsSize == 0 then+                 return ThreatAnotherUnarmed+               else do+                 msgAdd MsgSpottedThreat "Another threat, armed!"+                 return ThreatAnotherArmed+           else return ThreatNone  -- member of neutral faction+         aidVerbMU MsgSpottedActor aid verb+         friendAssocs <- getsState $ friendRegularAssocs side (blid body)+         case threat of+           ThreatNone -> return ()  -- too rare to care ATM+           ThreatUnarmed ->+             tutorialHintMsgAdd MeleeEnemies+           ThreatArmed ->+             tutorialHintMsgAdd UseTerrainEffect+           _ | length friendAssocs <= 1 -> return ()  -- one member on level+           ThreatAnotherUnarmed ->+             tutorialHintMsgAdd SwitchPointmanAndAvoidMeleeAlone+           ThreatAnotherArmed ->+             tutorialHintMsgAdd SwitchPointmanAndSoftenFoes+         animate (blid body) $ actorX (bpos body)++destroyActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m ()+destroyActorUI destroy aid b = do+  trunk <- getsState $ getItemBody $ btrunk b+  let baseColor = flavourToColor $ jflavour trunk+  unless (baseColor == Color.BrWhite) $  -- keep setup for heroes, etc.+    modifySession $ \sess -> sess {sactorUI = EM.delete aid $ sactorUI sess}+  let dummyTarget = TPoint TKnown (blid b) (bpos b)+      affect tgt = case tgt of+        Just (TEnemy a) | a == aid -> Just $+          if destroy then+            -- If *really* nothing more interesting, the actor will+            -- go to last known location to perhaps find other foes.+            dummyTarget+          else+            -- If enemy only hides (or we stepped behind obstacle) find him.+            TPoint (TEnemyPos a) (blid b) (bpos b)+        Just (TNonEnemy a) | a == aid -> Just dummyTarget+        _ -> tgt+  modifySession $ \sess -> sess {sxhair = affect $ sxhair sess}+  unless (bproj b || destroy) $+    modifySession $ \sess -> sess {slastLost = ES.insert aid $ slastLost sess}+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let gameOver = isJust $ gquit fact  -- we are the UI faction, so we determine+  unless gameOver $ do+    when (bfid b == side && not (bproj b)) $ do+      stopPlayBack+      let upd = ES.delete aid+      modifySession $ \sess -> sess {sselected = upd $ sselected sess}+      when destroy $ do+        mleader <- getsClient sleader+        when (isJust mleader)+          -- This is especially handy when the dead actor was a leader+          -- on a different level than the new one:+          clearAimMode+    -- If pushed, animate spotting again, to draw attention to pushing.+    markDisplayNeeded (blid b)++spotItemBag :: forall m. MonadClientUI m+            => Bool -> Container -> ItemBag -> m ()+spotItemBag verbose c bag = do+  -- This is due to a move, or similar, which will be displayed,+  -- so no extra @markDisplayNeeded@ needed here and in similar places.+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  side <- getsClient sside+  getKind <- getsState $ flip getIidKindId+  lid <- getsState $ lidFromC c+  localTime <- getsState $ getLocalTime lid+  factionD <- getsState sfactionD+  -- Queried just once, so many copies of a new item can be reported. OK.+  ItemRoles itemRoles <- getsSession sroles+  sxhairOld <- getsSession sxhair+  let resetXhair = case c of+        CFloor _ p -> case sxhairOld of+          Just TEnemy{} -> return ()  -- probably too important to overwrite+          Just (TPoint TEnemyPos{} _ _) -> return ()+          Just (TPoint TStash{} _ _) -> return ()+          Just (TVector _) -> return ()  -- explicitly set; keep it+          _ -> do+            -- Don't steal xhair if it's only an item on another level.+            -- For enemies, OTOH, capture xhair to alarm player.+            lidV <- viewedLevelUI+            when (lid == lidV) $ do+              bagFloor <- getsState $ getFloorBag lid p+              modifySession $ \sess ->+                sess { sxhair = Just $ TPoint (TItem bagFloor) lidV p+                     , sitemSel = Nothing }  -- reset flinging totally+        _ -> return ()+      locatedWhere = ppContainer factionD c+      beLocated = MU.Text $+        "be located" <+> if locatedWhere == ppContainer EM.empty c+                         then ""  -- boring+                         else locatedWhere+      subjectMaybe :: (ItemId, ItemQuant) -> m (Maybe (Int, MU.Part, MU.Part))+      subjectMaybe (iid, kit@(k, _)) = do+        recordItemLid iid c+        itemFull <- getsState $ itemToFull iid+        let arItem = aspectRecordFull itemFull+            slore = IA.loreFromContainer arItem c+        if iid `ES.member` (itemRoles EM.! slore)+        then return Nothing  -- this item or another with the same @iid@+                             -- seen already (has a role assigned); old news+        else do  -- never seen or would have a role+          assignItemRole c iid+          case c of+            CFloor{} -> do+              let subjectShort = partItemWsShortest rwidth side factionD k+                                                    localTime itemFull kit+                  subjectLong = partItemWsLong rwidth side factionD k+                                               localTime itemFull kit+              return $ Just (k, subjectShort, subjectLong)+            _ -> return Nothing+      -- @SortOn@ less efficient here, because function cheap.+      sortItems = sortOn (getKind . fst)+      sortedAssocs = sortItems $ EM.assocs bag+  subjectMaybes <- mapM subjectMaybe sortedAssocs+  let subjects = catMaybes subjectMaybes+      sendMsg plural = do+        let subjectShort = MU.WWandW $ map (\(_, part, _) -> part) subjects+            subjectLong = MU.WWandW $ map (\(_, _, part) -> part) subjects+            msg subject =+              if plural+              then makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes+                                                subject beLocated]+              else makeSentence [MU.SubjectVerbSg subject beLocated]+            msgShort = msg subjectShort+            msgLong = msg subjectLong+            dotsIfShorter = if msgShort == msgLong then "" else ".."+        resetXhair+        msgAddDistinct MsgSpottedItem (msgShort <> dotsIfShorter, msgLong)+  case subjects of+    [] -> return ()+    [(1, _, _)] -> sendMsg False+    _ -> sendMsg True+  when verbose $ case c of+    CActor aid store -> do+      let verb = MU.Text $ verbCStore store+      b <- getsState $ getActorBody aid+      fact <- getsState $ (EM.! bfid b) . sfactionD+      mleader <- getsClient sleader+      if Just aid == mleader && not (gunderAI fact) then+        manyItemsAidVerbMU MsgItemMovement aid verb sortedAssocs Right+      else when (not (bproj b) && bhp b > 0) $  -- don't announce death drops+        manyItemsAidVerbMU MsgItemMovement aid verb sortedAssocs (Left . Just)+    _ -> return ()++recordItemLid :: MonadClientUI m => ItemId -> Container -> m ()+recordItemLid iid c = do+  mjlid <- getsSession $ EM.lookup iid . sitemUI+  when (isNothing mjlid) $ do+    lid <- getsState $ lidFromC c+    modifySession $ \sess ->+      sess {sitemUI = EM.insert iid lid $ sitemUI sess}++moveActor :: MonadClientUI m => ActorId -> Point -> Point -> m ()+moveActor aid source target = do+  -- If source and target tile distant, assume it's a teleportation+  -- and display an animation. Note: jumps and pushes go through all+  -- intervening tiles, so won't be considered. Note: if source or target+  -- not seen, the (half of the) animation would be boring, just a delay,+  -- not really showing a transition, so we skip it (via 'breakUpdAtomic').+  -- The message about teleportation is sometimes shown anyway, just as the X.+  body <- getsState $ getActorBody aid+  if adjacent source target+  then markDisplayNeeded (blid body)+  else do+    let ps = (source, target)+    animate (blid body) $ teleport ps+  lookAtMove aid+  stopAtMove aid++displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m ()+displaceActorUI source target = do+  mleader <- getsClient sleader+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  spart <- partActorLeader source+  tpart <- partActorLeader target+  let msgClass = if mleader `elem` map Just [source, target]+                 then MsgActionMajor  -- to interrupt run after a displace;+                 else MsgActionMinor  -- configurable, animation is feedback+      msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart]+  msgAdd msgClass msg+  lookAtMove source+  stopAtMove source+  when (bfid sb /= bfid tb) $ do+    lookAtMove target  -- in case only this one is ours+    stopAtMove target+  side <- getsClient sside+  -- Ours involved, but definitely not requested by player via UI.+  when (side `elem` [bfid sb, bfid tb] && mleader /= Just source) stopPlayBack+  let ps = (bpos tb, bpos sb)+  animate (blid sb) $ swapPlaces ps++-- @UpdMoveItem@ is relatively rare (except within the player's faction),+-- but it ensures that even if only one of the stores is visible+-- (e.g., stash floor is not or actor posision is not), some messages+-- will be printed (via verbose @UpdLoseItem@).+moveItemUI :: MonadClientUI m+           => ItemId -> Int -> ActorId -> CStore -> CStore+           -> m ()+moveItemUI iid k aid cstore1 cstore2 = do+  let verb = MU.Text $ verbCStore cstore2+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  mleader <- getsClient sleader+  ItemRoles itemRoles <- getsSession sroles+  if iid `ES.member` (itemRoles EM.! SItem) then+    -- So far organs can't be put into stash, so no need to call+    -- @assignItemRole@ to add or reassign lore category.+    if cstore1 == CGround && Just aid == mleader && not (gunderAI fact) then+      itemAidVerbMU MsgActionMajor aid verb iid (Right k)+    else when (not (bproj b) && bhp b > 0) $  -- don't announce death drops+      itemAidVerbMU MsgActionMajor aid verb iid (Left k)+  else error $ "" `showFailure` (iid, k, aid, cstore1, cstore2)++-- The item may be used up already and so not present in the container,+-- e.g., if the item destroyed itself. This is OK. Message is still needed.+discover :: MonadClientUI m => Container -> ItemId -> m ()+discover c iid = do+  COps{coitem} <- getsState scops+  CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui+  lid <- getsState $ lidFromC c+  globalTime <- getsState stime+  localTime <- getsState $ getLocalTime lid+  itemFull <- getsState $ itemToFull iid+  bag <- getsState $ getContainerBag c+  side <- getsClient sside+  factionD <- getsState sfactionD+  (noMsg, nameWhere) <- case c of+    CActor aidOwner storeOwner -> do+      bOwner <- getsState $ getActorBody aidOwner+      name <- if bproj bOwner+              then return []+              else ppContainerWownW partActorLeader True c+      let arItem = aspectRecordFull itemFull+          inMetaGame = IA.checkFlag Ability.MetaGame arItem+          isOurOrgan = bfid bOwner == side+                       && storeOwner == COrgan+                       && not inMetaGame+            -- assume own faction organs known intuitively,+            -- except backstories and other meta game items+      return (isOurOrgan, name)+    CTrunk _ _ p | p == originPoint -> return (True, [])+      -- the special reveal at game over, using fake @CTrunk@; don't spam+    _ -> return (False, [])+  let kit = EM.findWithDefault quantSingle iid bag+              -- may be used up by that time+      knownName = makePhrase+        [partItemMediumAW rwidth side factionD localTime itemFull kit]+      flav = flavourToName $ jflavour $ itemBase itemFull+      (object1, object2) =+        partItemShortest rwidth side factionD localTime itemFull kit+      name1 = makePhrase [object1, object2]+      -- Make sure the two names in the message differ.+      (ikObvious, itemKind) = case jkind $ itemBase itemFull of+        IdentityObvious ik -> (True, ik)+        IdentityCovered _ix ik -> (False, ik)+          -- fake kind (template); OK, we talk about appearances+      name2 = IK.iname $ okind coitem itemKind+      name = if ikObvious && T.unwords (tail (T.words knownName)) /= name1+             then name1  -- avoid "a pair turns out to be"+             else name2  -- avoid "chip of scientific explanation"+      unknownName = MU.Phrase $ [MU.Text flav, MU.Text name] ++ nameWhere+      msg = makeSentence+        [ "the"+        , MU.SubjectVerbSg unknownName "turn out to be"+        , MU.Text knownName ]+  unless (noMsg || globalTime == timeZero) $  -- no spam about initial equipment+    msgAdd MsgItemDiscovery msg++ppHearMsg :: MonadClientUI m => Maybe Int -> HearMsg -> m Text+ppHearMsg distance hearMsg = case hearMsg of+  HearUpd cmd -> do+    COps{coTileSpeedup} <- getsState scops+    let sound = case cmd of+          UpdDestroyActor{} -> "shriek"+          UpdCreateItem{} -> "clatter"+          UpdTrajectory{} -> "thud"  -- A non-blast projectle hits a tile.+          UpdAlterTile _ _ fromTile toTile ->+            if | Tile.isOpenable coTileSpeedup fromTile+                 && Tile.isClosable coTileSpeedup toTile+                 || Tile.isClosable coTileSpeedup fromTile+                    && Tile.isOpenable coTileSpeedup toTile -> "creaking sound"+               | Tile.isWalkable coTileSpeedup fromTile+                 && Tile.isWalkable coTileSpeedup toTile -> "splash"+               | otherwise -> "rumble"+          UpdAlterExplorable _ k ->+            if k > 0 then "grinding noise" else "fizzing noise"+          _ -> error $ "" `showFailure` cmd+        adjective = MU.Text $ ppHearDistanceAdjective distance+        msg = makeSentence ["you hear", MU.AW $ MU.Phrase [adjective, sound]]+    return $! msg+  HearStrike ik -> do+    COps{coitem} <- getsState scops+    let verb = IK.iverbHit $ okind coitem ik+        adverb = MU.Text $ ppHearDistanceAdverb distance+        msg = makeSentence [ "you", adverb, "hear something"+                           , MU.Text verb, "someone" ]+    return $! msg+  HearSummon isProj grp p -> do+    let verb = if isProj then "something lure" else "somebody summon"+        part = MU.Text $ displayGroupName grp+        object = if p == 1  -- works, because exact number sent, not dice+                 then MU.AW part+                 else MU.Ws part+        adverb = MU.Text $ ppHearDistanceAdverb distance+    return $! makeSentence ["you", adverb, "hear", verb, object]+  HearCollideTile -> do+    let adverb = MU.Text $ ppHearDistanceAdverb distance+    return $! makeSentence ["you", adverb, "hear someone crash into something"]+  HearTaunt t -> do+    let adverb = MU.Text $ ppHearDistanceAdverb distance+    return $! makePhrase ["You", adverb, "overhear", MU.Text t]++ppHearDistanceAdjective :: Maybe Int -> Text+ppHearDistanceAdjective Nothing = "indistinct"+ppHearDistanceAdjective (Just 0) = "very close"+ppHearDistanceAdjective (Just 1) = "close"+ppHearDistanceAdjective (Just 2) = ""+ppHearDistanceAdjective (Just 3) = "remote"+ppHearDistanceAdjective (Just 4) = "distant"+ppHearDistanceAdjective (Just _) = "far-off"++ppHearDistanceAdverb :: Maybe Int -> Text+ppHearDistanceAdverb Nothing = "indistinctly"+ppHearDistanceAdverb (Just 0) = "very clearly"+ppHearDistanceAdverb (Just 1) = "clearly"+ppHearDistanceAdverb (Just 2) = ""+ppHearDistanceAdverb (Just 3) = "remotely"+ppHearDistanceAdverb (Just 4) = "distantly"+ppHearDistanceAdverb (Just _) = "barely"
+ engine-src/Game/LambdaHack/Common/Actor.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE DeriveGeneric, TupleSections #-}+-- | Actors in the game: heroes, monsters, etc.+module Game.LambdaHack.Common.Actor+  ( -- * The@ Acto@r type, its components and operations on them+    Actor(..), ResDelta(..), ActorMaxSkills, Watchfulness(..)+  , deltasSerious, deltasSeriousThisTurn+  , deltasHears, deltaBenign, deltaWasBenign+  , actorCanMelee, actorCanMeleeToHarm, actorWorthChasing, actorWorthKilling+  , gearSpeed, actorTemplate, actorWaits, actorWaitsOrSleeps, actorDying+  , hpTooLow, calmEnough, calmFull, hpFull, canSleep, prefersSleep+  , checkAdjacent, eqpOverfull, eqpFreeN+  , getCarriedIidsAndTrunk, getCarriedIidCStore+    -- * Assorted+  , ActorDict, monsterGenChance, smellTimeout+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import           Data.Int (Int64)+import           GHC.Generics (Generic)++import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | Actor attributes that are changing throughout the game.+-- If they appear to be dublets of aspects from actor kinds, e.g. HP,+-- they may be results of casting the dice specified in their respective+-- actor kind and/or may be modified temporarily, but return+-- to the original value from their respective kind over time.+--+-- Other properties of an actor, in particular its current aspects,+-- are derived from the actor's trunk, organs and equipment.+-- A class of the aspects, the boolean ones, are called flags.+-- Another class are skills. Stats are a subclass that determines+-- if particular actions are permitted for the actor (or faction).+data Actor = Actor+  { -- The trunk of the actor's body (present also in @borgan@ or @beqp@)+    btrunk      :: ItemId       -- ^ the trunk organ of the actor's body+  , bnumber     :: Maybe Int    -- ^ continued team character identity+                                --   index number in this game++    -- Resources+  , bhp         :: Int64        -- ^ current hit points * 1M+  , bhpDelta    :: ResDelta     -- ^ HP delta this turn * 1M+  , bcalm       :: Int64        -- ^ current calm * 1M+  , bcalmDelta  :: ResDelta     -- ^ calm delta this turn * 1M++    -- Location+  , bpos        :: Point        -- ^ current position+  , boldpos     :: Maybe Point  -- ^ previous position, if any+  , blid        :: LevelId      -- ^ current level+  , bfid        :: FactionId    -- ^ faction the actor currently belongs to+  , btrajectory :: Maybe ([Vector], Speed)+                                -- ^ trajectory the actor must+                                --   travel and his travel speed++    -- Items+  , borgan      :: ItemBag      -- ^ organs+  , beqp        :: ItemBag      -- ^ personal equipment+  , bweapon     :: Int          -- ^ number of weapons among eqp and organs+  , bweapBenign :: Int          -- ^ number of benign items among weapons++    -- Assorted+  , bwatch      :: Watchfulness -- ^ state of the actor's watchfulness+  , bproj       :: Bool         -- ^ is a projectile? affects being able+                                --   to fly through other projectiles, etc.+  }+  deriving (Show, Eq, Generic)++instance Binary Actor++-- | Representation of recent changes to HP of Calm of an actor.+-- This is reset every time the actor perfoms an action, so this is+-- aggregated over actor turn (move), not time turn.+-- The resource changes recorded in the tuple are, respectively,+-- negative and positive.+data ResDelta = ResDelta+  { resCurrentTurn  :: (Int64, Int64)  -- ^ resource change this move+  , resPreviousTurn :: (Int64, Int64)  -- ^ resource change previous move+  }+  deriving (Show, Eq, Generic)++instance Binary ResDelta++type ActorMaxSkills = EM.EnumMap ActorId Ability.Skills++-- | All actors on the level, indexed by actor identifier.+type ActorDict = EM.EnumMap ActorId Actor++data Watchfulness = WWatch | WWait Int | WSleep | WWake+  deriving (Show, Eq, Generic)++instance Binary Watchfulness++deltasSerious :: ResDelta -> Bool+deltasSerious ResDelta{..} = fst resCurrentTurn <= minusM2+                             || fst resPreviousTurn <= minusM2++deltasSeriousThisTurn :: ResDelta -> Bool+deltasSeriousThisTurn ResDelta{..} = fst resCurrentTurn <= minusM2++deltasHears :: ResDelta -> Bool+deltasHears ResDelta{..} = fst resCurrentTurn == minusM1+                           || fst resPreviousTurn == minusM1++deltaBenign :: ResDelta -> Bool+deltaBenign ResDelta{resCurrentTurn} =+  fst resCurrentTurn >= 0  -- only the current one++deltaWasBenign :: ResDelta -> Bool+deltaWasBenign ResDelta{resPreviousTurn} =+  fst resPreviousTurn >= 0  -- only the previous one++actorCanMelee :: ActorMaxSkills -> ActorId -> Actor -> Bool+{-# INLINE actorCanMelee #-}+actorCanMelee actorMaxSkills aid b =+  let actorMaxSk = actorMaxSkills EM.! aid+      condUsableWeapon = bweapon b > 0+      canMelee = Ability.getSk Ability.SkMelee actorMaxSk > 0+  in condUsableWeapon && canMelee++actorCanMeleeToHarm :: ActorMaxSkills -> ActorId -> Actor -> Bool+{-# INLINE actorCanMeleeToHarm #-}+actorCanMeleeToHarm actorMaxSkills aid b =+  let actorMaxSk = actorMaxSkills EM.! aid+      condUsableWeapon = bweapon b - bweapBenign b > 0+      canMelee = Ability.getSk Ability.SkMelee actorMaxSk > 0+  in condUsableWeapon && canMelee++-- Don't target/melee nonmoving actors, including sleeping, because nonmoving+-- can't be lured nor ambushed nor can chase us. However, do target+-- if they have loot or can attack at range or may become very powerful+-- through regeneration if left alone.+actorWorthChasing :: ActorMaxSkills -> ActorId -> Actor -> Bool+actorWorthChasing actorMaxSkills aid b =+  let hasLoot = not (EM.null $ beqp b)+        -- even consider "unreported inventory", for speed and KISS+      actorMaxSk = actorMaxSkills EM.! aid+  in bproj b+     || (Ability.getSk Ability.SkMove actorMaxSk > 0+         || bwatch b == WWake  -- probably will start moving very soon+         || hasLoot+         || Ability.getSk Ability.SkProject actorMaxSk > 0+         || bwatch b == WSleep+            && Ability.getSk Ability.SkMaxHP actorMaxSk > 30)+              -- too dangerous when regenerates through sleep;+              -- heroes usually fall into this category+        && bhp b > 0++-- Whether worth killing if already chased down.+actorWorthKilling :: ActorMaxSkills -> ActorId -> Actor -> Bool+actorWorthKilling actorMaxSkills aid b =+  actorWorthChasing actorMaxSkills aid b+  || actorCanMeleeToHarm actorMaxSkills aid b && bhp b > 0++-- | The speed from organs and gear; being pushed is ignored.+gearSpeed :: Ability.Skills -> Speed+gearSpeed actorMaxSk = toSpeed $+  max minSpeed (Ability.getSk Ability.SkSpeed actorMaxSk)  -- see @minimalSpeed@++actorTemplate :: ItemId -> Maybe Int -> Int64 -> Int64 -> Point -> LevelId+              -> FactionId -> Bool+              -> Actor+actorTemplate btrunk bnumber bhp bcalm bpos blid bfid bproj =+  let btrajectory = Nothing+      boldpos = Nothing+      borgan = EM.empty+      beqp = EM.empty+      bweapon = 0+      bweapBenign = 0+      bwatch = WWatch  -- overriden elsewhere, sometimes+      bhpDelta = ResDelta (0, 0) (0, 0)+      bcalmDelta = ResDelta (0, 0) (0, 0)+  in Actor{..}++actorWaits :: Actor -> Bool+{-# INLINE actorWaits #-}+actorWaits b = case bwatch b of+  WWait{} -> True+  _ -> False++actorWaitsOrSleeps :: Actor -> Bool+{-# INLINE actorWaitsOrSleeps #-}+actorWaitsOrSleeps b = case bwatch b of+  WWait{} -> True+  WSleep -> True+  _ -> False++-- | Projectile that ran out of steam or collided with obstacle, dies.+-- Even if it pierced through an obstacle, but lost its payload+-- while altering the obstacle during piercing, it dies, too.+actorDying :: Actor -> Bool+actorDying b = bhp b <= 0+               || bproj b && (maybe True (null . fst) (btrajectory b)+                              || EM.null (beqp b))++hpTooLow :: Actor -> Ability.Skills -> Bool+hpTooLow b actorMaxSk =+  5 * bhp b < xM (Ability.getSk Ability.SkMaxHP actorMaxSk) && bhp b <= xM 40+  || bhp b <= oneM++-- | Check if actor calm enough to perform some actions.+--+-- If max Calm is zero, always holds, to permit removing disastrous+-- equipped items, which would otherwise be stuck forever.+calmEnough :: Actor -> Ability.Skills -> Bool+calmEnough b actorMaxSk =+  let calmMax = Ability.getSk Ability.SkMaxCalm actorMaxSk+  in 2 * xM calmMax <= 3 * bcalm b++calmFull :: Actor -> Ability.Skills -> Bool+calmFull b actorMaxSk =+  let calmMax = Ability.getSk Ability.SkMaxCalm actorMaxSk+  in xM calmMax <= bcalm b++hpFull :: Actor -> Ability.Skills -> Bool+hpFull b actorMaxSk = xM (Ability.getSk Ability.SkMaxHP actorMaxSk) <= bhp b++-- | Has the skill and can wake up easily, so can sleep safely.+canSleep :: Ability.Skills -> Bool+canSleep actorMaxSk = Ability.getSk Ability.SkWait actorMaxSk >= 3+                      && (Ability.getSk Ability.SkSight actorMaxSk > 0+                          || Ability.getSk Ability.SkHearing actorMaxSk > 0)++-- | Can't loot, not too aggresive, so sometimes prefers to sleep+-- instead of exploring.+prefersSleep :: Ability.Skills -> Bool+prefersSleep actorMaxSk = Ability.getSk Ability.SkMoveItem actorMaxSk <= 0+                          && Ability.getSk Ability.SkAggression actorMaxSk < 2++checkAdjacent :: Actor -> Actor -> Bool+checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb)++eqpOverfull :: Actor -> Int -> Bool+eqpOverfull b n = let size = sum $ map fst $ EM.elems $ beqp b+                  in assert (size <= 10 `blame` (b, n, size))+                     $ size + n > 10++eqpFreeN :: Actor -> Int+eqpFreeN b = let size = sum $ map fst $ EM.elems $ beqp b+             in assert (size <= 10 `blame` (b, size))+                $ 10 - size++getCarriedIidsAndTrunk :: Actor -> [ItemId]+getCarriedIidsAndTrunk b =+  -- The trunk is important for a case of spotting a caught projectile+  -- with a stolen projecting item. This actually does happen.+  let trunk = EM.singleton (btrunk b) quantSingle+  in EM.keys $ EM.unionsWith const [beqp b, borgan b, trunk]++getCarriedIidCStore :: Actor -> [(ItemId, CStore)]+getCarriedIidCStore b =+  let bagCarried (cstore, bag) = map (,cstore) $ EM.keys bag+  in concatMap bagCarried [(CEqp, beqp b), (COrgan, borgan b)]++-- | Chance, in parts per million, that a new monster is generated.+-- Depends on the number of monsters already present, and on the level depth+-- and its cave kind.+--+-- Note that sometimes monsters spawn in groups, increasing danger,+-- but many monsters are generated asleep, decreasing initial danger.+monsterGenChance :: Dice.AbsDepth -> Dice.AbsDepth -> Int -> Int -> Int+monsterGenChance (Dice.AbsDepth ldepth) (Dice.AbsDepth totalDepth)+                 lvlSpawned actorCoeff =+  assert (totalDepth > 0 && ldepth > 0) $  -- ensured by content validation+    -- Heroes have to endure a level-depth-proportional wave of almost+    -- immediate spawners for each level. Then the monsters start+    -- to trickle more and more slowly, at the speed dictated+    -- by @actorCoeff@ specified in cave kind. Finally, spawning flattens out+    -- to ensure that camping is never safe.+    let scaledDepth = ldepth * 10 `div` totalDepth+        maxCoeff = 100 * 30+          -- spawning on a level with benign @actorCoeff@ flattens out+          -- after 30+depth spawns and on a level with fast spawning+          -- flattens out later, but ending at the same level+        coeff = max 1 $ min maxCoeff+                $ actorCoeff * (lvlSpawned - scaledDepth - 2)+        million = 1000000+    in 10 * million `div` coeff++-- | How long until an actor's smell vanishes from a tile.+smellTimeout :: Delta Time+smellTimeout = timeDeltaScale (Delta timeTurn) 200
+ engine-src/Game/LambdaHack/Common/ActorState.hs view
@@ -0,0 +1,486 @@+-- | Operations on the 'Actor' type, and related, that need the 'State' type,+-- but not our custom monad types.+module Game.LambdaHack.Common.ActorState+  ( fidActorNotProjGlobalAssocs, actorAssocs, fidActorRegularAssocs+  , fidActorRegularIds, foeRegularAssocs, foeRegularList+  , friendRegularAssocs, friendRegularList, bagAssocs, bagAssocsK+  , posToBig, posToBigAssoc, posToProjs, posToProjAssocs+  , posToAids, posToAidAssocs, calculateTotal, itemPrice, findIid, combinedItems+  , getActorBody, getActorMaxSkills, actorCurrentSkills, canTraverse+  , getCarriedAssocsAndTrunk, getContainerBag+  , getFloorBag, getEmbedBag, getBodyStoreBag, getFactionStashBag+  , mapActorItems_, getActorAssocs+  , memActor, getLocalTime, regenCalmDelta, actorInAmbient+  , dispEnemy, itemToFull, fullAssocs, kitAssocs+  , getItemKindId, getIidKindId, getItemKind, getIidKind+  , getItemKindIdServer, getIidKindIdServer, getItemKindServer, getIidKindServer+  , tileAlterable, lidFromC, posFromC, anyFoeAdj, anyHarmfulFoeAdj+  , adjacentBigAssocs, adjacentProjAssocs, armorHurtBonus, inMelee+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Int (Int64)+import           GHC.Exts (inline)++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++fidActorNotProjGlobalAssocs :: FactionId -> State -> [(ActorId, Actor)]+fidActorNotProjGlobalAssocs fid s =+  let f (_, b) = not (bproj b) && bfid b == fid+  in filter f $ EM.assocs $ sactorD s++actorAssocs :: (FactionId -> Bool) -> LevelId -> State+            -> [(ActorId, Actor)]+actorAssocs p lid s =+  let f (_, b) = blid b == lid && p (bfid b)+  in filter f $ EM.assocs $ sactorD s++actorRegularAssocs :: (FactionId -> Bool) -> LevelId -> State+                   -> [(ActorId, Actor)]+{-# INLINE actorRegularAssocs #-}+actorRegularAssocs p lid s =+  let f (_, b) = not (bproj b) && blid b == lid && p (bfid b) && bhp b > 0+  in filter f $ EM.assocs $ sactorD s++fidActorRegularAssocs :: FactionId -> LevelId -> State -> [(ActorId, Actor)]+fidActorRegularAssocs fid = actorRegularAssocs (== fid)++fidActorRegularIds :: FactionId -> LevelId -> State -> [ActorId]+fidActorRegularIds fid lid s =+  map fst $ actorRegularAssocs (== fid) lid s++foeRegularAssocs :: FactionId -> LevelId -> State -> [(ActorId, Actor)]+foeRegularAssocs fid lid s =+  let fact = (EM.! fid) . sfactionD $ s+  in actorRegularAssocs (inline isFoe fid fact) lid s++foeRegularList :: FactionId -> LevelId -> State -> [Actor]+foeRegularList fid lid s =+  let fact = (EM.! fid) . sfactionD $ s+  in map snd $ actorRegularAssocs (inline isFoe fid fact) lid s++friendRegularAssocs :: FactionId -> LevelId -> State -> [(ActorId, Actor)]+friendRegularAssocs fid lid s =+  let fact = (EM.! fid) . sfactionD $ s+  in actorRegularAssocs (inline isFriend fid fact) lid s++friendRegularList :: FactionId -> LevelId -> State -> [Actor]+friendRegularList fid lid s =+  let fact = (EM.! fid) . sfactionD $ s+  in map snd $ actorRegularAssocs (inline isFriend fid fact) lid s++bagAssocs :: State -> ItemBag -> [(ItemId, Item)]+bagAssocs s bag =+  let iidItem iid = (iid, getItemBody iid s)+  in map iidItem $ EM.keys bag++bagAssocsK :: State -> ItemBag -> [(ItemId, (Item, ItemQuant))]+bagAssocsK s bag =+  let iidItem (iid, kit) = (iid, (getItemBody iid s, kit))+  in map iidItem $ EM.assocs bag++posToBig :: Point -> LevelId -> State -> Maybe ActorId+posToBig pos lid s = posToBigLvl pos $ sdungeon s EM.! lid++posToBigAssoc :: Point -> LevelId -> State -> Maybe (ActorId, Actor)+posToBigAssoc pos lid s =+  let maid = posToBigLvl pos $ sdungeon s EM.! lid+  in fmap (\aid -> (aid, getActorBody aid s)) maid++posToProjs :: Point -> LevelId -> State -> [ActorId]+posToProjs pos lid s = posToProjsLvl pos $ sdungeon s EM.! lid++posToProjAssocs :: Point -> LevelId -> State -> [(ActorId, Actor)]+posToProjAssocs pos lid s =+  let l = posToProjsLvl pos $ sdungeon s EM.! lid+  in map (\aid -> (aid, getActorBody aid s)) l++posToAids :: Point -> LevelId -> State -> [ActorId]+posToAids pos lid s = posToAidsLvl pos $ sdungeon s EM.! lid++posToAidAssocs :: Point -> LevelId -> State -> [(ActorId, Actor)]+posToAidAssocs pos lid s =+  let l = posToAidsLvl pos $ sdungeon s EM.! lid+  in map (\aid -> (aid, getActorBody aid s)) l++-- | Calculate loot's worth for a given faction.+calculateTotal :: FactionId -> State -> (ItemBag, Int)+calculateTotal fid s =+  let bag = combinedItems fid s+      items = map (\(iid, (k, _)) -> (getItemBody iid s, k)) $ EM.assocs bag+      price (item, k) = itemPrice k $ getItemKind item s+  in (bag, sum $ map price items)++-- | Price an item, taking count into consideration.+itemPrice :: Int -> IK.ItemKind -> Int+itemPrice jcount itemKind = case lookup IK.VALUABLE $ IK.ifreq itemKind of+  Just k -> jcount * k+  Nothing -> 0++findIid :: ActorId -> FactionId -> ItemId -> State+        -> [(ActorId, (Actor, CStore))]+findIid leader fid iid s =+  let actors = fidActorNotProjGlobalAssocs fid s+      itemsOfActor (aid, b) =+        let itemsOfCStore store =+              let bag = getBodyStoreBag b store s+              in map (\iid2 -> (iid2, (aid, (b, store)))) (EM.keys bag)+            stores = [CEqp, COrgan] ++ [CStash | aid == leader]+        in concatMap itemsOfCStore stores+      items = concatMap itemsOfActor actors+  in map snd $ filter ((== iid) . fst) items++-- Trunk not considered (if stolen).+combinedItems :: FactionId -> State -> ItemBag+combinedItems fid s =+  let stashBag = getFactionStashBag fid s+      bs = map snd $ inline fidActorNotProjGlobalAssocs fid s+  in EM.unionsWith mergeItemQuant $ map beqp bs ++ [stashBag]++getActorBody :: ActorId -> State -> Actor+{-# INLINE getActorBody #-}+getActorBody aid s = sactorD s EM.! aid++-- For now, faction and doctrine skill modifiers only change+-- the stats that affect permitted actions (@SkMove..SkApply@),+-- so the expensive @actorCurrentSkills@ operation doesn't need to be used+-- when checking the other skills, e.g., for FOV calculations,+-- and the @getActorMaxSkills@ cheap operation suffices.+-- (@ModeKind@ content is not currently validated in this respect.)+getActorMaxSkills :: ActorId -> State -> Ability.Skills+{-# INLINE getActorMaxSkills #-}+getActorMaxSkills aid s = sactorMaxSkills s EM.! aid++actorCurrentSkills :: Maybe ActorId -> ActorId -> State -> Ability.Skills+actorCurrentSkills mleader aid s =+  let body = getActorBody aid s+      actorMaxSk = getActorMaxSkills aid s+      fact = (EM.! bfid body) . sfactionD $ s+      skillsFromDoctrine = Ability.doctrineSkills $ gdoctrine fact+      factionSkills+        | Just aid == mleader = Ability.zeroSkills+        | otherwise = fskillsOther (gkind fact)+                      `Ability.addSkills` skillsFromDoctrine+  in actorMaxSk `Ability.addSkills` factionSkills++-- Check that the actor can move, also between levels and through doors.+-- Otherwise, it's too awkward for human player to control, e.g.,+-- being stuck in a room with revolving doors closing after one turn+-- and the player needing to micromanage opening such doors with+-- another actor all the time. Completely immovable actors+-- e.g., an impregnable surveillance camera in a crowded corridor,+-- are less of a problem due to micromanagment, but more due to+-- the constant disturbing of other actor's running, etc.+canTraverse :: ActorId -> State -> Bool+canTraverse aid s =+  let actorMaxSk = getActorMaxSkills aid s+  in Ability.getSk Ability.SkMove actorMaxSk > 0+     && Ability.getSk Ability.SkAlter actorMaxSk >= fromEnum TK.talterForStairs++getCarriedAssocsAndTrunk :: Actor -> State -> [(ItemId, Item)]+getCarriedAssocsAndTrunk b s =+  -- The trunk is important for a case of spotting a caught projectile+  -- with a stolen projecting item. This actually does happen.+  let trunk = EM.singleton (btrunk b) quantSingle+  in bagAssocs s $ EM.unionsWith const [beqp b, borgan b, trunk]++getContainerBag :: Container -> State -> ItemBag+getContainerBag c s = case c of+  CFloor lid p -> getFloorBag lid p s+  CEmbed lid p -> getEmbedBag lid p s+  CActor aid cstore -> let b = getActorBody aid s+                       in getBodyStoreBag b cstore s+  CTrunk{} -> EM.empty  -- for dummy/test/analytics cases++getFloorBag :: LevelId -> Point -> State -> ItemBag+getFloorBag lid p s = EM.findWithDefault EM.empty p+                      $ lfloor (sdungeon s EM.! lid)++getEmbedBag :: LevelId -> Point -> State -> ItemBag+getEmbedBag lid p s = EM.findWithDefault EM.empty p+                      $ lembed (sdungeon s EM.! lid)++getBodyStoreBag :: Actor -> CStore -> State -> ItemBag+getBodyStoreBag b cstore s =+  case cstore of+    CGround -> getFloorBag (blid b) (bpos b) s+    COrgan -> borgan b+    CEqp -> beqp b+    CStash -> getFactionStashBag (bfid b) s++getFactionStashBag :: FactionId -> State -> ItemBag+getFactionStashBag fid s = case gstash $ sfactionD s EM.! fid of+  Just (lid, pos) -> getFloorBag lid pos s+  Nothing -> EM.empty++mapActorItems_ :: Monad m+               => (CStore -> ItemId -> ItemQuant -> m ()) -> Actor -> State+               -> m ()+mapActorItems_ f b s = do+  let notProcessed = [CGround]+      sts = [minBound..maxBound] \\ notProcessed+      g cstore = do+        let bag = getBodyStoreBag b cstore s+        mapM_ (uncurry $ f cstore) $ EM.assocs bag+  mapM_ g sts++getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, (Item, ItemQuant))]+getActorAssocs aid cstore s =+  let b = getActorBody aid s+  in bagAssocsK s $ getBodyStoreBag b cstore s++-- | Checks if the actor is present on the current level.+-- The order of argument here and in other functions is set to allow+--+-- > b <- getsState (memActor a)+memActor :: ActorId -> LevelId -> State -> Bool+memActor aid lid s =+  maybe False ((== lid) . blid) $ EM.lookup aid $ sactorD s++-- | Get current time from the dungeon data.+getLocalTime :: LevelId -> State -> Time+getLocalTime lid s = ltime $ sdungeon s EM.! lid++regenCalmDelta :: ActorId -> Actor -> State -> Int64+regenCalmDelta aid body s =+  let calmIncr = oneM  -- normal rate of calm regen+      actorMaxSk = getActorMaxSkills aid s+      maxDeltaCalm = xM (Ability.getSk Ability.SkMaxCalm actorMaxSk)+                     - bcalm body+      fact = (EM.! bfid body) . sfactionD $ s+      -- Worry actor by non-projectile enemies felt (even if not seen)+      -- on the level within 3 steps. Even dying, but not hiding in wait.+      isHeardFoe (!p, aid2) =+        let b = getActorBody aid2 s+        in inline chessDist p (bpos body) <= 3+           && not (actorWaitsOrSleeps b)  -- uncommon+           && inline isFoe (bfid body) fact (bfid b)  -- costly+      actorRelaxed = deltaBenign $ bcalmDelta body+      actorWasRelaxed = deltaWasBenign $ bcalmDelta body+  in if | not actorRelaxed -> 0+            -- if no foes around, do not compensate and obscure distress,+            -- otherwise, don't increase delta further and suggest grave harm;+            -- note that in the effect, an actor that first hears distant+            -- action and then hears nearby enemy, won't notice the latter,+            -- which can be justified by distraction and is KISS and tactical+        | any isHeardFoe $ EM.assocs $ lbig $ sdungeon s EM.! blid body ->+          minusM1  -- even if all calmness spent, keep informing the client;+                   -- from above we know delta won't get too large here+        | actorWasRelaxed -> min calmIncr (max 0 maxDeltaCalm)+                                             -- if Calm is over max+        | otherwise -> 0  -- don't regenerate if shortly after stress, to make+                          -- waking up actors via bad stealth easier++actorInAmbient :: Actor -> State -> Bool+actorInAmbient b s =+  let lvl = (EM.! blid b) . sdungeon $ s+  in Tile.isLit (coTileSpeedup $ scops s) (lvl `at` bpos b)++-- Check whether an actor can displace another. We assume they are adjacent+-- and they are foes.+dispEnemy :: ActorId -> ActorId -> Ability.Skills -> State -> Bool+dispEnemy source target actorMaxSk s =+  let hasBackup b =+        let adjAssocs = adjacentBigAssocs b s+            fact = sfactionD s EM.! bfid b+            friend (_, b2) = isFriend (bfid b) fact (bfid b2) && bhp b2 > 0+        in any friend adjAssocs+      sb = getActorBody source s+      tb = getActorBody target s+      tfact = sfactionD s EM.! bfid tb+  in bproj tb+     || not (actorDying tb+             || actorWaits tb+             || Ability.getSk Ability.SkMove actorMaxSk <= 0+                  -- sometimes this comes from sleep, but it's transient+                  -- and if we made exception for sleep, we would displace+                  -- immobile sleeping actors+             || Just (blid tb, bpos tb) == gstash tfact+             || hasBackup sb && hasBackup tb)  -- solo actors are flexible++itemToFull :: ItemId -> State -> ItemFull+itemToFull iid s =+  itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) iid (getItemBody iid s)++fullAssocs :: ActorId -> [CStore] -> State -> [(ItemId, ItemFull)]+fullAssocs aid cstores s =+  let allAssocs = concatMap (\cstore -> getActorAssocs aid cstore s) cstores+      iToFull (iid, (item, _kit)) =+        (iid, itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) iid item)+  in map iToFull allAssocs++kitAssocs :: ActorId -> [CStore] -> State -> [(ItemId, ItemFullKit)]+kitAssocs aid cstores s =+  let allAssocs = concatMap (\cstore -> getActorAssocs aid cstore s) cstores+      iToFull (iid, (item, kit)) =+        (iid, ( itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) iid item+              , kit ))+  in map iToFull allAssocs++getItemKindId :: Item -> State -> ContentId IK.ItemKind+getItemKindId item s = case jkind item of+  IdentityObvious ik -> ik+  IdentityCovered ix ik -> fromMaybe ik $ EM.lookup ix $ sdiscoKind s++getIidKindId :: ItemId -> State -> ContentId IK.ItemKind+getIidKindId iid s = getItemKindId (getItemBody iid s) s++getItemKind :: Item -> State -> IK.ItemKind+getItemKind item s = okind (coitem $ scops s) $ getItemKindId item s++getIidKind :: ItemId -> State -> IK.ItemKind+getIidKind iid s = getItemKind (getItemBody iid s) s++getItemKindIdServer :: Item -> State -> ContentId IK.ItemKind+getItemKindIdServer item s = case jkind item of+  IdentityObvious ik -> ik+  IdentityCovered ix _ik -> fromMaybe (error $ show $ jkind item)+                                      (EM.lookup ix $ sdiscoKind s)++getIidKindIdServer :: ItemId -> State -> ContentId IK.ItemKind+getIidKindIdServer iid s = getItemKindIdServer (getItemBody iid s) s++getItemKindServer :: Item -> State -> IK.ItemKind+getItemKindServer item s = okind (coitem $ scops s) $ getItemKindIdServer item s++getIidKindServer :: ItemId -> State -> IK.ItemKind+getIidKindServer iid s = getItemKindServer (getItemBody iid s) s++tileAlterable :: LevelId -> Point -> State -> Bool+tileAlterable lid pos s =+  let COps{coTileSpeedup} = scops s+      embeds = getEmbedBag lid pos s+      lvl = sdungeon s EM.! lid+      t = lvl `at` pos+      triggerable = any (\iid -> not $ null $ IK.ieffects $ getIidKind iid s)+                        (EM.keys embeds)+  in Tile.isModifiable coTileSpeedup t || triggerable++-- | Determine the dungeon level of the container. If the item is in+-- the shared stash, the level depends on which actor asks, not where+-- the stash is located physically.+lidFromC :: Container -> State -> LevelId+lidFromC (CFloor lid _) _ = lid+lidFromC (CEmbed lid _) _ = lid+lidFromC (CActor aid _) s = blid $ getActorBody aid s+lidFromC (CTrunk _ lid _) _ = lid++posFromC :: Container -> State -> Point+posFromC (CFloor _ pos) _ = pos+posFromC (CEmbed _ pos) _ = pos+posFromC (CActor aid _) s = bpos $ getActorBody aid s+posFromC c@CTrunk{} _ = error $ "" `showFailure` c++vicinityFoeAdj :: ((ActorId, Actor) -> Bool) -> ActorId -> State -> Bool+{-# INLINE vicinityFoeAdj #-}+vicinityFoeAdj predicate aid s =+  let body = getActorBody aid s+      lvl = (EM.! blid body) . sdungeon $ s+      fact = (EM.! bfid body) . sfactionD $ s+      f !p = case posToBigLvl p lvl of+        Nothing -> False+        Just aid2 -> let b2 = getActorBody aid2 s+                     in isFoe (bfid body) fact (bfid b2)+                        && predicate (aid2, b2)+      h !p = case posToProjsLvl p lvl of+        [] -> False+        aid2 : _ -> isFoe (bfid body) fact . bfid $ getActorBody aid2 s+  in any (\p -> f p || h p) $ vicinityUnsafe $ bpos body++-- | Require that any non-dying foe is adjacent. We include even+-- projectiles that explode when stricken down, because they can be caught+-- and then they don't explode, so it makes sense to focus on handling them.+-- If there are many projectiles in a single adjacent position, we only test+-- the first one, the one that would be hit in melee (this is not optimal+-- if the actor would need to flee instead of meleeing, but fleeing+-- with *many* projectiles adjacent is a possible waste of a move anyway).+anyFoeAdj :: ActorId -> State -> Bool+anyFoeAdj = vicinityFoeAdj (const True)++anyHarmfulFoeAdj :: ActorMaxSkills -> ActorId -> State -> Bool+anyHarmfulFoeAdj = vicinityFoeAdj . uncurry . actorWorthKilling++adjacentBigAssocs :: Actor -> State -> [(ActorId, Actor)]+{-# INLINE adjacentBigAssocs #-}+adjacentBigAssocs body s =+  let lvl = (EM.! blid body) . sdungeon $ s+      f !p = posToBigLvl p lvl+      g !aid = (aid, getActorBody aid s)+  in map g $ mapMaybe f $ vicinityUnsafe $ bpos body++adjacentProjAssocs :: Actor -> State -> [(ActorId, Actor)]+{-# INLINE adjacentProjAssocs #-}+adjacentProjAssocs body s =+  let lvl = (EM.! blid body) . sdungeon $ s+      f !p = posToProjsLvl p lvl+      g !aid = (aid, getActorBody aid s)+  in map g $ concatMap f $ vicinityUnsafe $ bpos body++armorHurtBonus :: ActorId -> ActorId -> State -> Int+armorHurtBonus source target s =+  let sb = getActorBody source s+      sMaxSk = getActorMaxSkills source s+      tMaxSk = getActorMaxSkills target s+  in armorHurtCalculation (bproj sb) sMaxSk tMaxSk++-- | Check if any non-dying foe is adjacent to any of our normal actors+-- and either can harm them via melee or can attack from a distance.+-- Otherwise no point meleeing him. Projectiles are ignored, because+-- they are not actively attempted to melee, see @meleeAny@.+-- This is regardless of whether our actor can melee or just needs to flee,+-- in which case alert is needed so that he is not slowed down by others.+-- However, if our actor can't move nor melee, no real combat is taking place.+-- This is needed only by AI and computed as lazily as possible.+inMelee :: ActorMaxSkills -> FactionId -> LevelId -> State -> Bool+inMelee !actorMaxSkills !fid !lid s =+  let fact = sfactionD s EM.! fid+      f (!aid, !b) =+        blid b == lid+        && not (bproj b)+        && inline isFoe fid fact (bfid b)  -- costly+        && actorWorthKilling actorMaxSkills aid b+      allFoes = filter f $ EM.assocs $ sactorD s+      g (!aid, !b) = bfid b == fid+                     && blid b == lid+                     && not (bproj b)+                     && bhp b > 0+                     && let actorMaxSk = actorMaxSkills EM.! aid+                        in Ability.getSk Ability.SkMove actorMaxSk > 0+                           || actorCanMeleeToHarm actorMaxSkills aid b+      allOurs = filter g $ EM.assocs $ sactorD s+      -- We assume foes are less numerous, even though they may come+      -- from multiple factions and they contain projectiles,+      -- because we see all our actors, while many foes may be hidden.+      -- Consequently, we allocate the set of foe positions+      -- and avoid allocating ours, by iterating over our actors.+      -- This in O(mn) instead of O(m+n), but it allocates+      -- less and multiplicative constants are lower.+      -- We inspect adjacent locations of foe positions, not of ours,+      -- thus increasing allocation a bit, but not by much, because+      -- the set should be rather saturated.+      -- If there are no foes in sight, we don't iterate at all.+      setFoeVicinity =+        ES.fromList $ concatMap (vicinityUnsafe . bpos . snd) allFoes+  in not (ES.null setFoeVicinity)  -- shortcut+     && any (\(_, b) -> bpos b `ES.member` setFoeVicinity) allOurs
+ engine-src/Game/LambdaHack/Common/Analytics.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Per-actor analytics of personal feats.+module Game.LambdaHack.Common.Analytics+  ( FactionAnalytics, ActorAnalytics, GenerationAnalytics+  , KillMap, Analytics(..), KillHow(..)+  , emptyAnalytics, addFactionKill, addActorKill+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , addKill+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import           GHC.Generics (Generic)++import Game.LambdaHack.Common.Types+import Game.LambdaHack.Definition.Defs++-- | Summary analytics data for each faction.+type FactionAnalytics = EM.EnumMap FactionId Analytics++-- | Analytics data for each live actor.+type ActorAnalytics = EM.EnumMap ActorId Analytics++-- | Statistics of possible and actual generation of items for each lore kind.+type GenerationAnalytics = EM.EnumMap SLore (EM.EnumMap ItemId Int)++-- | Labels of individual kill count analytics.+data KillHow =+    KillKineticMelee+  | KillKineticRanged+  | KillKineticBlast+  | KillKineticPush+  | KillOtherMelee+  | KillOtherRanged+  | KillOtherBlast+  | KillOtherPush+  | KillActorLaunch+  | KillTileLaunch+  | KillDropLaunch+  | KillCatch+  deriving (Show, Eq, Enum, Generic)++instance Binary KillHow++type KillMap = EM.EnumMap FactionId (EM.EnumMap ItemId Int)++-- | Statistics of past events concerning an actor.+newtype Analytics = Analytics+  { akillCounts :: EM.EnumMap KillHow KillMap+  }+  deriving (Show, Eq, Binary)++emptyAnalytics :: Analytics+emptyAnalytics = Analytics+  { akillCounts = EM.empty+  }++addKill :: KillHow -> FactionId -> ItemId -> Maybe Analytics -> Analytics+addKill killHow fid iid =+  let f Nothing = Analytics {akillCounts =+        EM.singleton killHow $ EM.singleton fid $ EM.singleton iid 1}+      f (Just an) = an {akillCounts =+        EM.alter g killHow $ akillCounts an}+      g Nothing = Just $ EM.singleton fid $ EM.singleton iid 1+      g (Just fidMap) = Just $ EM.alter h fid fidMap+      h Nothing = Just $ EM.singleton iid 1+      h (Just iidMap) = Just $ EM.alter i iid iidMap+      i Nothing = Just 1+      i (Just n) = Just $ n + 1+  in f++addFactionKill :: FactionId -> KillHow -> FactionId -> ItemId+               -> FactionAnalytics+               -> FactionAnalytics+addFactionKill fidOfKiller killHow fid iid =+  EM.alter (Just . addKill killHow fid iid) fidOfKiller++addActorKill :: ActorId -> KillHow -> FactionId -> ItemId+             -> ActorAnalytics+             -> ActorAnalytics+addActorKill aid killHow fid iid =+  EM.alter (Just . addKill killHow fid iid) aid
+ engine-src/Game/LambdaHack/Common/Area.hs view
@@ -0,0 +1,87 @@+-- | Rectangular areas of levels and their basic operations.+module Game.LambdaHack.Common.Area+  ( Area, toArea, fromArea, spanArea, trivialArea, isTrivialArea+  , inside, shrink, expand, middlePoint, areaInnerBorder, sumAreas, punindex+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Data.Binary++import Game.LambdaHack.Common.Point+import Game.LambdaHack.Definition.Defs++-- | The type of areas. The bottom left and the top right points.+data Area = Area X Y X Y+  deriving (Show, Eq)++-- | Checks if it's an area with at least one field.+toArea :: (X, Y, X, Y) -> Maybe Area+toArea (x0, y0, x1, y1) = if x0 <= x1 && y0 <= y1+                          then Just $ Area x0 y0 x1 y1+                          else Nothing++fromArea :: Area -> (X, Y, X, Y)+{-# INLINE fromArea #-}+fromArea (Area x0 y0 x1 y1) = (x0, y0, x1, y1)++-- Funny thing, Trivial area, a point, has span 1 in each dimension.+spanArea :: Area -> (Point, X, Y)+spanArea (Area x0 y0 x1 y1) = (Point x0 y0, x1 - x0 + 1, y1 - y0 + 1)++trivialArea :: Point -> Area+trivialArea (Point x y) = Area x y x y++isTrivialArea :: Area -> Bool+isTrivialArea (Area x0 y0 x1 y1) = x0 == x1 && y0 == y1++-- | Checks that a point belongs to an area.+inside :: Area -> Point -> Bool+{-# INLINE inside #-}+inside = insideP . fromArea++-- | Shrink the given area on all fours sides by the amount.+shrink :: Area -> Maybe Area+shrink (Area x0 y0 x1 y1) = toArea (x0 + 1, y0 + 1, x1 - 1, y1 - 1)++expand :: Area -> Area+expand (Area x0 y0 x1 y1) = Area (x0 - 1) (y0 - 1) (x1 + 1) (y1 + 1)++middlePoint :: Area -> Point+middlePoint (Area x0 y0 x1 y1) = Point (x0 + (x1 - x0) `div` 2)+                                       (y0 + (y1 - y0) `div` 2)++areaInnerBorder :: Area -> [Point]+areaInnerBorder (Area x0 y0 x1 y1) =+  [ Point x y+  | x <- [x0, x1], y <- [y0..y1] ]+  ++ [ Point x y+     | x <- [x0+1..x1-1], y <- [y0, y1] ]++-- We assume the areas are adjacent.+sumAreas :: Area -> Area -> Area+sumAreas a@(Area x0 y0 x1 y1) a'@(Area x0' y0' x1' y1') =+  if | y1 == y0' -> assert (x0 == x0' && x1 == x1' `blame` (a, a')) $+       Area x0 y0 x1 y1'+     | y0 == y1' -> assert (x0 == x0' && x1 == x1' `blame` (a, a')) $+       Area x0' y0' x1' y1+     | x1 == x0' -> assert (y0 == y0' && y1 == y1' `blame` (a, a')) $+       Area x0 y0 x1' y1+     | x0 == x1' -> assert (y0 == y0' && y1 == y1' `blame` (a, a')) $+       Area x0' y0' x1 y1'+     | otherwise -> error $ "areas not adjacent" `showFailure` (a, a')++punindex :: X -> Int -> Point+{-# INLINE punindex #-}+punindex xsize n = let (py, px) = n `quotRem` xsize+                   in Point{..}++instance Binary Area where+  put (Area x0 y0 x1 y1) = do+    put x0+    put y0+    put x1+    put y1+  get = Area <$> get <*> get <*> get <*> get
+ engine-src/Game/LambdaHack/Common/ClientOptions.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Options that affect the behaviour of the client.+module Game.LambdaHack.Common.ClientOptions+  ( FullscreenMode(..), ClientOptions(..), defClientOptions+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Control.DeepSeq+import Data.Binary+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Misc++-- | Kinds of fullscreen or windowed mode. See <https://hackage.haskell.org/package/sdl2-2.5.3.0/docs/SDL-Video.html#t:WindowMode>.+data FullscreenMode =+    NotFullscreen        -- ^ a normal window instead of fullscreen+  | BigBorderlessWindow  -- ^ fake fullscreen; window the size of the desktop;+                         --   this is the preferred one, if it works+  | ModeChange           -- ^ real fullscreen with a video mode change+  deriving (Show, Read, Eq, Generic)++instance NFData FullscreenMode++instance Binary FullscreenMode++-- | Options that affect the behaviour of the client (but not game rules).+data ClientOptions = ClientOptions+  { schosenFontset    :: Maybe Text+      -- ^ Font set chosen by the player for the whole UI.+  , sallFontsScale    :: Maybe Double+      -- ^ The scale applied to all fonts, resizing the whole UI.+  , sfonts            :: [(Text, FontDefinition)]+      -- ^ Available fonts as defined in config file.+  , sfontsets         :: [(Text, FontSet)]+      -- ^ Available font sets as defined in config file.+  , sfullscreenMode   :: Maybe FullscreenMode+      -- ^ Whether to start in fullscreen mode and in which one.+  , slogPriority      :: Maybe Int+      -- ^ How much to log (e.g., from SDL). 1 is all, 5 is errors, the default.+  , smaxFps           :: Maybe Double+      -- ^ 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.+  , sdisableAutoYes   :: Bool+      -- ^ Never auto-answer all prompts, even if under AI control.+  , snoAnim           :: Maybe Bool+      -- ^ Don't show any animations.+  , snewGameCli       :: Bool+      -- ^ Start a new game, overwriting the save file.+  , sbenchmark        :: Bool+      -- ^ Don't create directories and files and show time stats.+  , sbenchMessages    :: Bool+      -- ^ Display messages in realistic was under AI control (e.g., for benchmarking).+  , stitle            :: Maybe String+  , ssavePrefixCli    :: String+      -- ^ Prefix of the save game file name.+  , sfrontendANSI     :: Bool+      -- ^ Whether to use the ANSI frontend.+  , sfrontendTeletype :: Bool+      -- ^ Whether to use the stdout/stdin frontend.+  , sfrontendNull     :: Bool+      -- ^ Whether to use null (no input/output) frontend.+  , sfrontendLazy     :: Bool+      -- ^ Whether to use lazy (output not even calculated) frontend.+  , sdbgMsgCli        :: Bool+      -- ^ Show clients' internal debug messages.+  , sstopAfterSeconds :: Maybe Int+  , sstopAfterFrames  :: Maybe Int+  , sprintEachScreen  :: Bool+  , sexposePlaces     :: Bool+  , sexposeItems      :: Bool+  , sexposeActors     :: Bool+  }+  deriving (Show, Eq, Generic)++instance Binary ClientOptions++-- | Default value of client options.+defClientOptions :: ClientOptions+defClientOptions = ClientOptions+  { schosenFontset = Nothing+  , sallFontsScale = Nothing+  , sfonts = []+  , sfontsets = []+  , sfullscreenMode = Nothing+  , slogPriority = Nothing+  , smaxFps = Nothing+  , sdisableAutoYes = False+  , snoAnim = Nothing+  , snewGameCli = False+  , sbenchmark = False+  , sbenchMessages = False+  , stitle = Nothing+  , ssavePrefixCli = ""+  , sfrontendANSI = False+  , sfrontendTeletype = False+  , sfrontendNull = False+  , sfrontendLazy = False+  , sdbgMsgCli = False+  , sstopAfterSeconds = Nothing+  , sstopAfterFrames = Nothing+  , sprintEachScreen = False+  , sexposePlaces = False+  , sexposeItems = False+  , sexposeActors = False+  }
+ engine-src/Game/LambdaHack/Common/Faction.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE DeriveGeneric, TupleSections #-}+-- | Factions taking part in the game, e.g., a hero faction, a monster faction+-- and an animal faction.+module Game.LambdaHack.Common.Faction+  ( FactionDict, Faction(..), Diplomacy(..)+  , Status(..), Challenge(..)+  , tshowDiplomacy, tshowChallenge, gleader, isHorrorFact, noRunWithMulti+  , bannedPointmanSwitchBetweenLevels, isFoe, isFriend+  , difficultyBound, difficultyDefault, difficultyCoeff+  , defaultChallenge, possibleActorFactions, ppContainer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , Dipl+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import           GHC.Generics (Generic)++import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.ModeKind (ModeKind)+import           Game.LambdaHack.Core.Frequency+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs++-- | All factions in the game, indexed by faction identifier.+type FactionDict = EM.EnumMap FactionId Faction++-- | The faction datatype.+data Faction = Faction+  { gkind     :: FactionKind+      -- ^ the player spec for this faction, do not update!+      -- it is morally read-only, but not represented+      -- as @ContentId FactionKind@, because it's very small+      -- and it's looked up often enough in the code and during runtime;+      -- a side-effect is that if content changes mid-game, this stays;+      -- if we ever have thousands of factions in a single game,+      -- e.g., one for each separately spawned herd of animals, change this+  , gname     :: Text            -- ^ individual name+  , gcolor    :: Color.Color     -- ^ color of numbered actors+  , gdoctrine :: Ability.Doctrine+                                 -- ^ non-pointmen behave according to this+  , gunderAI  :: Bool            -- ^ whether the faction is under AI control+  , ginitial  :: [(Int, Int, GroupName ItemKind)]  -- ^ initial actors+  , gdipl     :: Dipl            -- ^ diplomatic standing+  , gquit     :: Maybe Status    -- ^ cause of game end/exit+  , _gleader  :: Maybe ActorId   -- ^ the leader of the faction; don't use+                                 --   in place of sleader on clients+  , gstash    :: Maybe (LevelId, Point)+                                 -- ^ level and position of faction's+                                 --   shared inventory stash+  , gvictims  :: EM.EnumMap (ContentId ItemKind) Int  -- ^ members killed+  }+  deriving (Show, Eq, Generic)++instance Binary Faction++-- | Diplomacy states. Higher overwrite lower in case of asymmetric content.+data Diplomacy =+    Unknown+  | Neutral+  | Alliance+  | War+  deriving (Show, Eq, Ord, Enum, Generic)++instance Binary Diplomacy++type Dipl = EM.EnumMap FactionId Diplomacy++-- | Current game status.+data Status = Status+  { stOutcome :: Outcome  -- ^ current game outcome+  , stDepth   :: Int      -- ^ depth of the final encounter+  , stNewGame :: Maybe (GroupName ModeKind)+                          -- ^ new game group to start, if any+  }+  deriving (Show, Eq, Ord, Generic)++instance Binary Status++-- | The difficulty level influencess HP of either the human player or the AI.+-- The challenges restrict some abilities of the human player only.+data Challenge = Challenge+  { cdiff   :: Int   -- ^ game difficulty level (HP bonus or malus)+  , cfish   :: Bool  -- ^ cold fish challenge (no healing from enemies)+  , cgoods  :: Bool  -- ^ ready goods challenge (crafting disabled)+  , cwolf   :: Bool  -- ^ lone wolf challenge (only one starting character)+  , ckeeper :: Bool  -- ^ finder keeper challenge (ranged attacks disabled)+  }+  deriving (Show, Eq, Ord, Generic)++instance Binary Challenge++tshowDiplomacy :: Diplomacy -> Text+tshowDiplomacy Unknown = "unknown to each other"+tshowDiplomacy Neutral = "in neutral diplomatic relations"+tshowDiplomacy Alliance = "allied"+tshowDiplomacy War = "at war"++tshowChallenge :: Challenge -> Text+tshowChallenge Challenge{..} =+  "("+  <> T.intercalate ", "+    (["difficulty" <+> tshow cdiff | cdiff /= difficultyDefault]+     ++ ["cold fish" | cfish]+     ++ ["ready goods" | cgoods]+     ++ ["lone wolf" | cwolf]+     ++ ["finder keeper" | ckeeper])+  <> ")"++gleader :: Faction -> Maybe ActorId+gleader = _gleader++-- | Tell whether the faction consists of summoned horrors only.+--+-- Horror player is special, for summoned actors that don't belong to any+-- of the main players of a given game. E.g., animals summoned during+-- a skirmish game between two hero factions land in the horror faction.+-- In every game, either all factions for which summoning items exist+-- should be present or a horror player should be added to host them.+isHorrorFact :: Faction -> Bool+isHorrorFact fact = fromMaybe 0 (lookup IK.HORROR $ fgroups $ gkind fact) > 0++-- A faction where other actors move at once or where some of leader change+-- is automatic can't run with multiple actors at once. That would be+-- overpowered or too complex to keep correct.+--+-- Note that this doesn't take into account individual actor skills,+-- so this is overly restrictive and, OTOH, sometimes running will fail+-- or behave wierdly regardless. But it's simple and easy to understand+-- by the UI user.+noRunWithMulti :: Faction -> Bool+noRunWithMulti fact =+  let skillsOther = fskillsOther $ gkind fact+  in Ability.getSk Ability.SkMove skillsOther >= 0+     || bannedPointmanSwitchBetweenLevels fact+     || not (fhasPointman (gkind fact))++bannedPointmanSwitchBetweenLevels :: Faction -> Bool+bannedPointmanSwitchBetweenLevels = fspawnsFast . gkind++-- | Check if factions are at war. Assumes symmetry.+isFoe :: FactionId -> Faction -> FactionId -> Bool+isFoe fid1 fact1 fid2 =+  fid1 /= fid2  -- shortcut+  && War == EM.findWithDefault Unknown fid2 (gdipl fact1)++-- | Check if factions are allied. Assumes symmetry.+isAlly :: Faction -> FactionId -> Bool+{-# INLINE isAlly #-}+isAlly fact1 fid2 = Alliance == EM.findWithDefault Unknown fid2 (gdipl fact1)++-- | Check if factions are allied or are the same faction. Assumes symmetry.+isFriend :: FactionId -> Faction -> FactionId -> Bool+isFriend fid1 fact1 fid2 = fid1 == fid2 || isAlly fact1 fid2++difficultyBound :: Int+difficultyBound = 9++difficultyDefault :: Int+difficultyDefault = (1 + difficultyBound) `div` 2++-- The function is its own inverse.+difficultyCoeff :: Int -> Int+difficultyCoeff n = difficultyDefault - n++defaultChallenge :: Challenge+defaultChallenge = Challenge { cdiff = difficultyDefault+                             , cfish = False+                             , cgoods = False+                             , cwolf = False+                             , ckeeper = False }++possibleActorFactions :: [GroupName ItemKind] -> ItemKind -> FactionDict+                      -> Frequency (FactionId, Faction)+possibleActorFactions itemGroups itemKind factionD =+  let candidatesFromGroups grps =+        let h (fid, fact) =+              let f grp (grp2, n) = [(n, (fid, fact)) | grp == grp2]+                  g grp = concatMap (f grp) (fgroups (gkind fact))+              in concatMap g grps+        in concatMap h $ EM.assocs factionD+      allCandidates =+        [ candidatesFromGroups itemGroups  -- when origin known/matters+        , candidatesFromGroups $ map fst $ IK.ifreq itemKind  -- otherwise+        , map (1,) $ filter (isHorrorFact . snd)+          $ EM.assocs factionD  -- fall back+        , map (1,) $ EM.assocs factionD  -- desperate fall back+        ]+  in case filter (not . null) allCandidates of+    [] -> error "possibleActorFactions: no faction found for an actor"+    candidates : _ -> toFreq "possibleActorFactions" candidates++ppContainer :: FactionDict -> Container -> Text+ppContainer factionD (CFloor lid p) =+  let f fact = case gstash fact of+        Just (slid, sp) | slid == lid && sp == p -> Just $ gname fact+        _ -> Nothing+  in case mapMaybe f $ EM.elems factionD of+    [] -> "nearby"+    [t] -> "in the shared inventory stash of" <+> t+    _ -> "in a shared zone of interests"+ppContainer _ CEmbed{} = "embedded nearby"+ppContainer _ (CActor _ cstore) = ppCStoreIn cstore+ppContainer _ c@CTrunk{} = error $ "" `showFailure` c
+ engine-src/Game/LambdaHack/Common/File.hs view
@@ -0,0 +1,13 @@+-- | Saving/loading to files, with serialization and compression.+module Game.LambdaHack.Common.File+  ( encodeEOF, strictDecodeEOF+  , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile+  ) where++import Prelude ()++#ifdef USE_JSFILE+import Game.LambdaHack.Common.JSFile+#else+import Game.LambdaHack.Common.HSFile+#endif
+ engine-src/Game/LambdaHack/Common/HSFile.hs view
@@ -0,0 +1,95 @@+-- | Saving/loading to files, with serialization and compression.+module Game.LambdaHack.Common.HSFile+  ( encodeEOF, strictDecodeEOF+  , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , encodeData+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Codec.Compression.Zlib as Z+import qualified Control.Exception as Ex+import           Data.Binary+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text.IO as T+import           Data.Version+import           System.Directory+import           System.FilePath+import           System.IO+  ( IOMode (..)+  , hClose+  , hSetEncoding+  , localeEncoding+  , openBinaryFile+  , readFile+  , utf8+  , withBinaryFile+  , withFile+  )++-- | Serialize and save data.+-- Note that LBS.writeFile opens the file in binary mode.+encodeData :: Binary a => FilePath -> a -> IO ()+encodeData path a = do+  let tmpPath = path <.> "tmp"+  Ex.bracketOnError+    (openBinaryFile tmpPath WriteMode)+    (\h -> hClose h >> removeFile tmpPath)+    (\h -> do+       LBS.hPut h . encode $ a+       hClose h+       renameFile tmpPath path+    )++-- | Serialize, compress and save data with an EOF marker.+-- The @OK@ is used as an EOF marker to ensure any apparent problems with+-- corrupted files are reported to the user ASAP.+encodeEOF :: Binary b => FilePath -> Version -> b -> IO ()+encodeEOF path v b =+  encodeData path (v, (Z.compress $ encode b, "OK" :: String))++-- | Read, decompress and deserialize data with an EOF marker.+-- The @OK@ EOF marker ensures any easily detectable file corruption+-- is discovered and reported before any value is decoded from+-- the second component and before the file handle is closed.+-- OTOH, binary encoding corruption is not discovered until a version+-- check elswere ensures that binary formats are compatible.+strictDecodeEOF :: Binary b => FilePath -> IO (Version, b)+strictDecodeEOF path =+  withBinaryFile path ReadMode $ \h -> do+    c1 <- LBS.hGetContents h+    let (v1, (c2, s)) = decode c1+    return $! if s == ("OK" :: String)+              then (v1, decode $ Z.decompress c2)+              else error $ "Fatal error: corrupted file " ++ path++-- | Try to create a directory, if it doesn't exist. We catch exceptions+-- in case many clients try to do the same thing at the same time.+tryCreateDir :: FilePath -> IO ()+tryCreateDir dir = do+  dirExists <- doesDirectoryExist dir+  unless dirExists $+    Ex.handle (\(_ :: Ex.IOException) -> return ())+              (createDirectory dir)++-- | Try to write a file, given content, if the file not already there.+-- We catch exceptions in case many clients and/or the server try to do+-- the same thing at the same time. Using `Text.IO` to avoid UTF conflicts+-- with OS or filesystem.+tryWriteFile :: FilePath -> Text -> IO ()+tryWriteFile path content = do+  fileExists <- doesFileExist path+  unless fileExists $ do+    -- With some luck, locale was already corrected in Main.hs, but just+    -- in case, we make sure not to save UTF files in too primitve encodings.+    let enc = localeEncoding+    Ex.handle (\(ex :: Ex.IOException) -> print $ show ex) $+      withFile path WriteMode $ \h -> do+        when (show enc `elem` ["ASCII", "ISO-8859-1", "ISO-8859-2"]) $+          hSetEncoding h utf8+        T.hPutStr h content
+ engine-src/Game/LambdaHack/Common/HighScore.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | High score table operations.+module Game.LambdaHack.Common.HighScore+  ( ScoreTable, ScoreDict+  , empty, register, showScore, showAward+  , getTable, unTable, getRecord, getStatus, getDate+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , ScoreRecord, insertPos+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import           GHC.Generics (Generic)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Content.ItemKind (ItemKind)+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Definition.Defs++-- | 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         :: POSIXTime  -- ^ date of the last game interruption+  , status       :: Status     -- ^ reason of the game interruption+  , challenge    :: Challenge  -- ^ challenge setup of the game+  , gkindName    :: Text       -- ^ name of the faction's gkind+  , ourVictims   :: EM.EnumMap (ContentId ItemKind) Int  -- ^ allies lost+  , theirVictims :: EM.EnumMap (ContentId ItemKind) Int  -- ^ foes killed+  }+  deriving (Eq, Ord, Generic)++instance Binary ScoreRecord++-- | The list of scores, in decreasing order.+newtype ScoreTable = ScoreTable {unTable :: [ScoreRecord]}+  deriving (Eq, Binary)++instance Show ScoreTable where+  show _ = "a score table"++-- | A dictionary from game mode IDs to scores tables.+type ScoreDict = EM.EnumMap (ContentId ModeKind) ScoreTable++-- | Empty score table+empty :: ScoreDict+empty = EM.empty++-- | Insert a new score into the table, Return new table and the ranking.+-- Make sure the table doesn't grow too large.+insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int)+insertPos s (ScoreTable table) =+  let (prefix, suffix) = span (> s) table+      pos = length prefix + 1+  in (ScoreTable $ prefix ++ [s] ++ take (100 - pos) suffix, pos)++-- | Register a new score in a score table.+register :: ScoreTable  -- ^ old table+         -> Int         -- ^ the total value of faction items+         -> Int         -- ^ the total value of dungeon items+         -> Time        -- ^ game time spent+         -> Status      -- ^ reason of the game interruption+         -> POSIXTime   -- ^ current date+         -> Challenge   -- ^ challenge setup+         -> Text        -- ^ name of the faction's gkind+         -> EM.EnumMap (ContentId ItemKind) Int  -- ^ allies lost+         -> EM.EnumMap (ContentId ItemKind) Int  -- ^ foes killed+         -> HiCondPoly+         -> (Bool, (ScoreTable, Int))+register table total dungeonTotal time status@Status{stOutcome}+         date challenge gkindName ourVictims theirVictims hiCondPoly =+  let turnsSpent = intToDouble $ timeFitUp time timeTurn+      hiInValue (hi, c) = assert (total <= dungeonTotal) $ case hi of+        HiConst -> c+        HiLoot | dungeonTotal == 0 -> c  -- a fluke; no gold generated+        HiLoot -> c * intToDouble total / intToDouble dungeonTotal+        HiSprint -> -- Up to -c turns matter.+          let speedup = max 0 (-c - turnsSpent)+          in if c >= -10000+             then speedup  -- every turn matters+             else 10000 * speedup / (-c)  -- prevent exploit speedruns+        HiBlitz -> -- Up to 1000000/-c turns matter.+                   sqrt $ max 0 (1000000 + c * turnsSpent)+        HiSurvival -> -- Up to 1000000/c turns matter.+                      sqrt $ max 0 (min 1000000 $ c * turnsSpent)+        HiKill -> c * intToDouble (sum (EM.elems theirVictims))+        HiLoss -> c * intToDouble (sum (EM.elems ourVictims))+      hiPolynomialValue = sum . map hiInValue+      hiSummandValue (hiPoly, outcomes) =+        if stOutcome `elem` outcomes+        then max 0 (hiPolynomialValue hiPoly)+        else 0+      hiCondValue = sum . map hiSummandValue+      -- Other challenges than HP difficulty are not reflected in score.+      points = ceiling+               $ hiCondValue hiCondPoly+                 * 1.5 ^^ (- (difficultyCoeff (cdiff challenge)))+      negTime = absoluteTimeNegate time+      score = ScoreRecord{..}+  in (points > 0 || turnsSpent > 100, insertPos score table)+       -- even if stash looted and all gold lost, count highscore if long game++-- | Show a single high score, from the given ranking in the high score table.+showScore :: TimeZone -> Int -> ScoreRecord -> [Text]+showScore tz pos score =+  let Status{stOutcome, stDepth} = status score+      died = nameOutcomePast stOutcome <+> case stOutcome of+        Killed -> "on level" <+> tshow (abs stDepth)+        _ -> ""+      curDate = T.take 19 . tshow . utcToLocalTime tz+                . posixSecondsToUTCTime . date $ score+      turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn+      tpos = T.justifyRight 3 ' ' $ tshow pos+      tscore = T.justifyRight 6 ' ' $ tshow $ points score+      victims = let nkilled = sum $ EM.elems $ theirVictims score+                    nlost = sum $ EM.elems $ ourVictims score+                in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost+      -- This may overfill the screen line, but with default fonts+      -- it's very unlikely and not a big problem in any case.+      chalText | challenge score == defaultChallenge = ""+               | otherwise = tshowChallenge (challenge score)+      tturns = makePhrase [MU.CarWs turns "turn"]+  in [ tpos <> "." <+> tscore <+> gkindName score+       <+> died <> "," <+> victims <> ","+     , "           "+       <> "after" <+> tturns <+> chalText <+> "on" <+> curDate <> "."+     ]++getTable :: ContentId ModeKind -> ScoreDict -> ScoreTable+getTable = EM.findWithDefault (ScoreTable [])++getRecord :: Int -> ScoreTable -> ScoreRecord+getRecord pos (ScoreTable table) =+  fromMaybe (error $ "" `showFailure` pos)+  $ listToMaybe $ drop (pred pos) table++getStatus :: ScoreRecord -> Status+getStatus = status++getDate :: ScoreRecord -> POSIXTime+getDate = date++showAward :: Int        -- ^ number of (3-line) scores to be shown+          -> ScoreTable -- ^ current score table+          -> Int        -- ^ position of the current score in the table+          -> Text       -- ^ the name of the game mode+          -> Text+showAward height table pos gameModeName =+  let posStatus = status $ getRecord pos table+      (efforts, person, msgUnless) =+        case stOutcome posStatus of+          Killed | stDepth posStatus <= 1 ->+            ("your short-lived struggle", MU.Sg3rd, "(no bonus)")+          Killed ->+            ("your heroic deeds", MU.PlEtc, "(no bonus)")+          Defeated ->+            ("your futile efforts", MU.PlEtc, "(no bonus)")+          Camping ->+            -- This is only according to the limited player knowledge;+            -- the final score can be different, which is fine:+            ("your valiant exploits", MU.PlEtc, "")+          Conquer ->+            ("your ruthless victory", MU.Sg3rd,+             if pos <= height && length (unTable table) > 3+             then "among the best"  -- "greatest heroes" doesn't fit+             else "(bonus included)")+          Escape ->+            ("your dashing coup", MU.Sg3rd,+             if pos <= height && length (unTable table) > 3+             then "among the best"+             else "(bonus included)")+          Restart ->+            ("your abortive attempt", MU.Sg3rd, "(no bonus)")+      subject = makePhrase [efforts, "in", MU.Text gameModeName]+  in makeSentence+       [ MU.SubjectVerb person MU.Yes (MU.Text subject) "award you"+       , MU.Ordinal pos, "place", msgUnless ]
+ engine-src/Game/LambdaHack/Common/Item.hs view
@@ -0,0 +1,506 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TupleSections #-}+-- | Weapons, treasure and all the other items in the game.+module Game.LambdaHack.Common.Item+  ( Item(..), ItemIdentity(..)+  , ItemKindIx, ItemDisco(..), ItemFull(..), ItemFullKit+  , DiscoveryKind, DiscoveryAspect, ItemIxMap, Benefit(..), DiscoveryBenefit+  , ItemTimer, ItemTimers, ItemQuant, ItemBag, ItemDict+  , toItemKindIx, quantSingle, itemToFull6, aspectRecordFull, strongestSlot+  , itemTimerZero, createItemTimer, shiftItemTimer+  , deltaOfItemTimer, charging, ncharges, hasCharge+  , strongestMelee, unknownMeleeBonus, unknownSpeedBonus+  , conditionMeleeBonus, conditionSpeedBonus, armorHurtCalculation+  , mergeItemQuant, listToolsToConsume, subtractIidfromGrps, sortIids+  , TileAction (..), parseTileAction+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , valueAtEqpSlot, unknownAspect, countIidConsumed+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Hashable (Hashable)+import qualified Data.Ix as Ix+import           GHC.Generics (Generic)++import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Definition.Ability (EqpSlot (..))+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.Flavour++-- | Game items in actor possesion or strewn around the dungeon.+-- The information contained in this time is available to the player+-- from the moment the item is first seen and is never mutated.+--+-- Some items are not created identified (@IdentityCovered@).+-- Then they are presented as having a template kind that is really+-- not their own, though usually close. Full kind information about+-- item's kind is available through the @ItemKindIx@ index once the item+-- is identified and full information about the value of item's aspect record+-- is available elsewhere (both @IdentityObvious@ and @IdentityCovered@+-- items may or may not need identification of their aspect record).+data Item = Item+  { jkind    :: ItemIdentity     -- ^ the kind of the item, or an indirection+  , jfid     :: Maybe FactionId  -- ^ the faction that created the item, if any+  , jflavour :: Flavour          -- ^ flavour, always the real one,+                                 --   it's not hidden; people may not recognize+                                 --   shape, but they remember colour and old+                                 --   vs fancy look+  }+  deriving (Show, Eq, Generic)++instance Binary Item++-- | Either the explicit obvious kind of the item or the kind it's hidden under,+-- with the details covered under the index indirection.+data ItemIdentity =+    IdentityObvious (ContentId IK.ItemKind)+  | IdentityCovered ItemKindIx (ContentId IK.ItemKind)+  deriving (Show, Eq, Generic)++instance Hashable ItemIdentity++instance Binary ItemIdentity++-- | The map of item ids to item aspect record. The full map is known+-- by the server.+type DiscoveryAspect = EM.EnumMap ItemId IA.AspectRecord++-- | An index of the kind identifier of an item. Clients have partial knowledge+-- how these idexes map to kind ids. They gain knowledge by identifying items.+-- The indexes and kind identifiers are 1-1.+newtype ItemKindIx = ItemKindIx Word16+  deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary)++-- | The secret part of the information about an item. If a faction+-- knows the aspect record of the item, this is the complete secret information.+-- Items that don't need second identification (the @kmConst@ flag is set)+-- may be identified or not and both cases are OK (their display flavour+-- will differ and that may be the point).+data ItemDisco =+    ItemDiscoFull IA.AspectRecord+  | ItemDiscoMean IA.KindMean+ deriving (Show, Ord, Eq)++-- No speedup from making fields non-strict.+-- | Full information about an item.+data ItemFull = ItemFull+  { itemBase    :: Item+  , itemKindId  :: ContentId IK.ItemKind+  , itemKind    :: IK.ItemKind+  , itemDisco   :: ItemDisco+  , itemSuspect :: Bool+  }+  deriving Show++type ItemFullKit = (ItemFull, ItemQuant)++-- | The map of item kind indexes to item kind ids.+-- The full map, as known by the server, is 1-1.+-- Because it's sparse and changes, we don't represent it as an (unboxed)+-- vector, until it becomes a bottleneck (if ever, likely on JS, where only+-- vectors are fast).+type DiscoveryKind = EM.EnumMap ItemKindIx (ContentId IK.ItemKind)++-- | The map of item kind indexes to identifiers of items that have that kind.+-- Used to update data about items when their kinds become known, e.g.,+-- AI item use benefit data.+type ItemIxMap = EM.EnumMap ItemKindIx (ES.EnumSet ItemId)++-- | The fields are, in order:+-- 1. whether the item should be kept in equipment (not in stash)+-- 2. the total benefit from picking the item up (to use or to put in equipment)+-- 3. the benefit of applying the item to self+-- 4. the (usually negative, for him) value of hitting a foe in melee with it+-- 5. the (usually negative, for him) value of flinging the item at an opponent+data Benefit = Benefit+  { benInEqp  :: Bool+  , benPickup :: Double+  , benApply  :: Double+  , benMelee  :: Double+  , benFling  :: Double+  }+  deriving (Show, Generic)++instance Binary Benefit++type DiscoveryBenefit = EM.EnumMap ItemId Benefit++-- | The absolute level's local time at which an item's copy becomes+-- operational again. Even if item is not identified and so its timeout+-- unknown, it's enough to compare this to the local level time+-- to learn whether an item is recharged.+--+-- This schema causes timeout jumps for items in stash, but timeout+-- is reset when items move, so this is a minor problem.+-- Global time can't be used even only for items in stash,+-- or exploit would be possible when an actor on a desolate level waits+-- to recharge items for actors on a busy level. It's probably+-- impossible to avoid such exploits or, otherwise, timeout jumps,+-- particularly for faction where many actors move on many levels+-- and so an item in stash is not used by a single actor at a time.+newtype ItemTimer = ItemTimer {itemTimer :: Time}+  deriving (Show, Eq, Binary)++type ItemTimers = [ItemTimer]++-- | Number of items in a bag, together with recharging timer, in case of+-- items that need recharging, exists only temporarily or auto-activate+-- at regular intervals. Data invariant: the length of the timer+-- should be less or equal to the number of items.+type ItemQuant = (Int, ItemTimers)++-- | A bag of items, e.g., one of the stores of an actor or the items+-- on a particular floor position or embedded in a particular map tile.+type ItemBag = EM.EnumMap ItemId ItemQuant++-- | All items in the dungeon (including those carried by actors),+-- indexed by item identifier.+type ItemDict = EM.EnumMap ItemId Item++toItemKindIx :: Word16 -> ItemKindIx+{-# INLINE toItemKindIx #-}+toItemKindIx = ItemKindIx++quantSingle :: ItemQuant+quantSingle = (1, [])++itemToFull6 :: COps -> DiscoveryKind -> DiscoveryAspect -> ItemId -> Item+            -> ItemFull+itemToFull6 COps{coitem, coItemSpeedup} discoKind discoAspect iid itemBase =+  let (itemKindId, itemSuspect) = case jkind itemBase of+        IdentityObvious ik -> (ik, False)+        IdentityCovered ix ik ->+          maybe (ik, True) (, False) $ ix `EM.lookup` discoKind+      itemKind = okind coitem itemKindId+      km = getKindMean itemKindId coItemSpeedup+      -- If the kind is not identified, we know nothing about the real+      -- aspect record, so we at least assume they are variable.+      itemAspectMean | itemSuspect = km {IA.kmConst = False}+                     | otherwise = km+      itemDisco = case EM.lookup iid discoAspect of+        Just itemAspect -> ItemDiscoFull itemAspect+        Nothing -> ItemDiscoMean itemAspectMean+  in ItemFull {..}++aspectRecordFull :: ItemFull -> IA.AspectRecord+aspectRecordFull itemFull =+  case itemDisco itemFull of+    ItemDiscoFull itemAspect -> itemAspect+    ItemDiscoMean itemAspectMean -> IA.kmMean itemAspectMean++-- This ignores items that don't go into equipment, as determined in @benInEqp@.+-- They are removed from equipment elsewhere via @harmful@.+strongestSlot :: DiscoveryBenefit -> Ability.EqpSlot -> [(ItemId, ItemFullKit)]+              -> [(Int, (ItemId, ItemFullKit))]+strongestSlot discoBenefit eqpSlot is =+  let f (iid, (itemFull, kit)) =+        let Benefit{benInEqp, benPickup, benMelee} = discoBenefit EM.! iid+        in if not benInEqp+           then Nothing+           else Just $+             let ben = case eqpSlot of+                   EqpSlotWeaponFast ->+                       -- For equipping/unequipping the main reliable weapon,+                       -- we take into account not only melee damage,+                       -- but also timeout, aspects, etc.+                       ceiling benPickup+                   EqpSlotWeaponBig ->+                       -- For equipping/unequipping the one-shot big hitter+                       -- weapon, we take into account only melee damage+                       -- and we don't even care if it's durable.+                       -- The backup is ready in the slot above, after all.+                       ceiling (- benMelee)+                   _ -> valueAtEqpSlot eqpSlot $ aspectRecordFull itemFull+                 idBonus = if itemSuspect itemFull then 1000 else 0+                 arItem = aspectRecordFull itemFull+                 -- Equip good uniques for flavour and fun from unique effects.+                 uniqueBonus = if IA.checkFlag Ability.Unique arItem && ben > 20+                               then 1000+                               else 0+             in (ben + idBonus + uniqueBonus, (iid, (itemFull, kit)))+  in sortBy (flip $ comparing fst) $ mapMaybe f is++valueAtEqpSlot :: EqpSlot -> IA.AspectRecord -> Int+valueAtEqpSlot eqpSlot arItem@IA.AspectRecord{..} =+  case eqpSlot of+    EqpSlotMove -> Ability.getSk Ability.SkMove aSkills+    EqpSlotMelee -> Ability.getSk Ability.SkMelee aSkills+    EqpSlotDisplace -> Ability.getSk Ability.SkDisplace aSkills+    EqpSlotAlter -> Ability.getSk Ability.SkAlter aSkills+    EqpSlotWait -> Ability.getSk Ability.SkWait aSkills+    EqpSlotMoveItem -> Ability.getSk Ability.SkMoveItem aSkills+    EqpSlotProject -> Ability.getSk Ability.SkProject aSkills+    EqpSlotApply -> Ability.getSk Ability.SkApply aSkills+    EqpSlotSwimming -> Ability.getSk Ability.SkSwimming aSkills+    EqpSlotFlying -> Ability.getSk Ability.SkFlying aSkills+    EqpSlotHurtMelee -> Ability.getSk Ability.SkHurtMelee aSkills+    EqpSlotArmorMelee -> Ability.getSk Ability.SkArmorMelee aSkills+    EqpSlotArmorRanged -> Ability.getSk Ability.SkArmorRanged aSkills+    EqpSlotMaxHP -> Ability.getSk Ability.SkMaxHP aSkills+    EqpSlotSpeed -> Ability.getSk Ability.SkSpeed aSkills+    EqpSlotSight -> Ability.getSk Ability.SkSight aSkills+    EqpSlotShine -> Ability.getSk Ability.SkShine aSkills+    EqpSlotMiscBonus ->+      aTimeout  -- usually better items have longer timeout+      + Ability.getSk Ability.SkMaxCalm aSkills+      + Ability.getSk Ability.SkSmell aSkills+      + Ability.getSk Ability.SkNocto aSkills+          -- powerful, but hard to boost over aSight+    EqpSlotWeaponFast -> error $ "" `showFailure` arItem  -- sum of all benefits+    EqpSlotWeaponBig -> error $ "" `showFailure` arItem  -- sum of all benefits++itemTimerZero :: ItemTimer+itemTimerZero = ItemTimer timeZero++createItemTimer :: Time -> Delta Time -> ItemTimer+createItemTimer localTime delta = ItemTimer $ localTime `timeShift` delta++shiftItemTimer :: Delta Time -> ItemTimer -> ItemTimer+shiftItemTimer delta t = ItemTimer $ itemTimer t `timeShift` delta++deltaOfItemTimer :: Time -> ItemTimer -> Delta Time+deltaOfItemTimer localTime t = timeDeltaToFrom (itemTimer t) localTime++charging :: Time -> ItemTimer -> Bool+charging localTime = (> localTime) . itemTimer++ncharges :: Time -> ItemQuant -> Int+ncharges localTime (itemK, itemTimers) =+  itemK - length (filter (charging localTime) itemTimers)++hasCharge :: Time -> ItemQuant -> Bool+hasCharge localTime kit = ncharges localTime kit > 0++strongestMelee :: Bool -> Maybe DiscoveryBenefit -> Time+               -> [(ItemId, ItemFullKit)]+               -> [(Double, Bool, Int, Int, ItemId, ItemFullKit)]+strongestMelee _ _ _ [] = []+strongestMelee ignoreCharges mdiscoBenefit localTime kitAss =+  -- For fighting, as opposed to equipping, we value weapon only for+  -- its raw damage and harming effects and at this very moment only,+  -- not in the future. Hehce, we exclude discharged weapons.+  let f (iid, ifk@(itemFull, kit)) =+        let rawDmg = IK.damageUsefulness $ itemKind itemFull+            unIDedBonus = if itemSuspect itemFull then 1000 else 0+            totalValue = case mdiscoBenefit of+              Just discoBenefit ->+                let Benefit{benMelee} = discoBenefit EM.! iid+                in benMelee - unIDedBonus+              Nothing -> - rawDmg  -- special case: not interested about ID+            arItem = aspectRecordFull itemFull+            timeout = IA.aTimeout arItem+            -- This is crucial for weapons for which AI is too silly+            -- to value the effects at more than 0, even though they are strong+            -- and also to prefer weapons with burn or wound over pure damage,+            -- which is a good rule of thumb before late game at least.+            hasEffect = any IK.forApplyEffect+                            (IK.ieffects $ itemKind itemFull)+            ncha = ncharges localTime kit+        in if ignoreCharges || ncha > 0+           then Just (totalValue, hasEffect, timeout, ncha, iid, ifk)+           else Nothing+  -- We can't filter out weapons that are not harmful to victim+  -- (@benMelee >= 0), because actors use them if nothing else available,+  -- e.g., geysers, bees. This is intended and fun.+  in sortOn (\(value, hasEffect, timeout, _, _, (itemFull, _)) ->+                -- Weapon with higher timeout activated first to increase+                -- the chance of using it again during this fight.+                -- No timeout is ever better, because no wait incurred.+                -- Optimal packing problem: start with the biggest.+                let timN = if timeout == 0 then -99999 else - timeout+                in (value, not hasEffect, timN, itemKindId itemFull))+            (mapMaybe f kitAss)++unknownAspect :: (IK.Aspect -> [Dice.Dice]) -> ItemFull -> Bool+unknownAspect f itemFull@ItemFull{itemKind=IK.ItemKind{iaspects}, ..} =+  case itemDisco of+    ItemDiscoMean IA.KindMean{kmConst} ->+      let arItem = aspectRecordFull itemFull+          unknown x = let (minD, maxD) = Dice.infsupDice x+                      in minD /= maxD+      in itemSuspect && not (IA.checkFlag Ability.MinorAspects arItem)+         || not kmConst && or (concatMap (map unknown . f) iaspects)+    ItemDiscoFull{} -> False  -- all known++-- We assume @SkHurtMelee@ never appears inside @Odds@. If it does,+-- not much harm.+unknownMeleeBonus :: [ItemFull] -> Bool+unknownMeleeBonus =+  let p (IK.AddSkill Ability.SkHurtMelee k) = [k]+      p _ = []+      f itemFull b = b || unknownAspect p itemFull+  in foldr f False++-- We assume @SkSpeed@ never appears inside @Odds@. If it does,+-- not much harm.+unknownSpeedBonus :: [ItemFull] -> Bool+unknownSpeedBonus =+  let p (IK.AddSkill Ability.SkSpeed k) = [k]+      p _ = []+      f itemFull b = b || unknownAspect p itemFull+  in foldr f False++conditionMeleeBonus :: [ItemFullKit] -> Int+conditionMeleeBonus kitAss =+  let f (itemFull, (itemK, _)) k =+        let arItem = aspectRecordFull itemFull+        in if IA.checkFlag Ability.Condition arItem+           then k + itemK * IA.getSkill Ability.SkHurtMelee arItem+           else k+  in foldr f 0 kitAss++conditionSpeedBonus :: [ItemFullKit] -> Int+conditionSpeedBonus kitAss =+  let f (itemFull, (itemK, _)) k =+        let arItem = aspectRecordFull itemFull+        in if IA.checkFlag Ability.Condition arItem+           then k + itemK * IA.getSkill Ability.SkSpeed arItem+           else k+  in foldr f 0 kitAss++-- | Damage calculation. The armor and hurt skills are additive.+-- They can't be multiplicative, because then 100% armor would minimize+-- damage regardless of even 200% hurt skill.+-- However, additive skills make the relative effectiveness of weapons+-- dependent on the enemy, so even with -100% hurt skill a kinetic weapon+-- can't be removed from the list, because an enemy may have+-- negative armor skill. This is bad, but also KISS.+armorHurtCalculation :: Bool -> Ability.Skills -> Ability.Skills -> Int+armorHurtCalculation proj sMaxSk tMaxSk =+  let trim200 n = min 200 $ max (-200) n+      itemBonus =+        trim200 (Ability.getSk Ability.SkHurtMelee sMaxSk)+        - if proj+          then trim200 (Ability.getSk Ability.SkArmorRanged tMaxSk)+          else trim200 (Ability.getSk Ability.SkArmorMelee tMaxSk)+  in 100 + max (-95) itemBonus  -- at least 5% of damage gets through++mergeItemQuant :: ItemQuant -> ItemQuant -> ItemQuant+mergeItemQuant (k2, it2) (k1, it1) = (k1 + k2, it1 ++ it2)++listToolsToConsume :: [(ItemId, ItemFullKit)] -> [(ItemId, ItemFullKit)]+                   -> [((CStore, Bool), (ItemId, ItemFullKit))]+listToolsToConsume kitAssG kitAssE =+  let isDurable = IA.checkFlag Ability.Durable+                  . aspectRecordFull . fst . snd+      (kitAssGT, kitAssGF) = partition isDurable kitAssG+      (kitAssET, kitAssEF) = partition isDurable kitAssE+      -- Non-durable tools take precedence, because durable+      -- are applied and, usually being weapons,+      -- may be harmful or may have unintended effects.+      -- CGround takes precedence, too.+  in zip (repeat (CGround, False)) kitAssGF+     ++ zip (repeat (CEqp, False)) kitAssEF+     ++ zip (repeat (CGround, True)) kitAssGT+     ++ zip (repeat (CEqp, True)) kitAssET++countIidConsumed :: ItemFullKit+                 -> [(Bool, Int, GroupName IK.ItemKind)]+                 -> (Int, Int, [(Bool, Int, GroupName IK.ItemKind)])+countIidConsumed (ItemFull{itemKind}, (k, _)) grps0 =+  let hasGroup grp =+        maybe False (> 0) $ lookup grp $ IK.ifreq itemKind+      matchGroup (nToApplyIfDurable, nToDestroyAlways, grps)+                 (destroyAlways, n, grp) =+        if hasGroup grp+        then let mkn = min k n  -- even if durable, use each copy only once+                 grps2 = if n - mkn > 0+                         then (destroyAlways, n - mkn, grp) : grps+                         else grps+             in if destroyAlways+                then ( nToApplyIfDurable+                     , max nToDestroyAlways mkn+                     , grps2 )+                else ( max nToApplyIfDurable mkn+                     , nToDestroyAlways+                     , grps2 )+        else ( nToApplyIfDurable+             , nToDestroyAlways+             , (destroyAlways, n, grp) : grps )+  in foldl' matchGroup (0, 0, []) grps0++subtractIidfromGrps :: ( EM.EnumMap CStore ItemBag+                       , [(CStore, (ItemId, ItemFull))]+                       , [(Bool, Int, GroupName IK.ItemKind)] )+                    -> ((CStore, Bool), (ItemId, ItemFullKit))+                    -> ( EM.EnumMap CStore ItemBag+                       , [(CStore, (ItemId, ItemFull))]+                       , [(Bool, Int, GroupName IK.ItemKind)] )+subtractIidfromGrps (bagsToLose1, iidsToApply1, grps1)+                    ((store, durable), (iid, itemFullKit@(itemFull, (_, it)))) =+  let (nToApplyIfDurable, nToDestroyAlways, grps2) =+        countIidConsumed itemFullKit grps1+      (nToApply, nToDestroy) = if durable+                               then (nToApplyIfDurable, nToDestroyAlways)+                               else (0, max nToApplyIfDurable nToDestroyAlways)+  in ( if nToDestroy == 0+       then bagsToLose1  -- avoid vacuus @UpdDestroyItem@+       else let kit2 = (nToDestroy, take nToDestroy it)+                removedBags = EM.singleton store $ EM.singleton iid kit2+            in EM.unionWith (EM.unionWith mergeItemQuant)+                            removedBags bagsToLose1+     , replicate nToApply (store, (iid, itemFull)) ++ iidsToApply1+     , grps2 )++sortIids :: (ItemId -> ItemFull)+         -> [(ItemId, ItemQuant)]+         -> [(ItemId, ItemQuant)]+sortIids itemToF =+  -- If appearance and aspects the same, keep the order from before sort.+  let kindAndAppearance (iid, _) =+        let ItemFull{itemBase=Item{..}, ..} = itemToF iid+        in ( not itemSuspect, itemKindId, itemDisco+           , IK.isymbol itemKind, IK.iname itemKind+           , jflavour, jfid )+  in sortOn kindAndAppearance++data TileAction =+    EmbedAction (ItemId, ItemQuant)+  | ToAction (GroupName TK.TileKind)+  | WithAction [(Int, GroupName IK.ItemKind)] (GroupName TK.TileKind)+  deriving Show++parseTileAction :: Bool -> Bool -> [(IK.ItemKind, (ItemId, ItemQuant))]+                -> TK.Feature+                -> Maybe TileAction+parseTileAction bproj underFeet embedKindList feat = case feat of+  TK.Embed igroup ->+      -- Greater or equal 0 to also cover template UNKNOWN items+      -- not yet identified by the client.+    let f (itemKind, _) =+          fromMaybe (-1) (lookup igroup $ IK.ifreq itemKind) >= 0+    in case find f embedKindList of+      Nothing -> Nothing+      Just (_, iidkit) -> Just $ EmbedAction iidkit+  TK.OpenTo tgroup | not (underFeet || bproj) -> Just $ ToAction tgroup+  TK.CloseTo tgroup | not (underFeet || bproj) -> Just $ ToAction tgroup+  TK.ChangeTo tgroup | not bproj -> Just $ ToAction tgroup+  TK.OpenWith proj grps tgroup | not underFeet ->+    if proj == TK.ProjNo && bproj+    then Nothing+    else Just $ WithAction grps tgroup+  TK.CloseWith proj grps tgroup | not underFeet ->+    -- Not when standing on tile, not to autoclose doors under actor+    -- or close via dropping an item inside.+    if proj == TK.ProjNo && bproj+    then Nothing+    else Just $ WithAction grps tgroup+  TK.ChangeWith proj grps tgroup ->+    if proj == TK.ProjNo && bproj+    then Nothing+    else Just $ WithAction grps tgroup+  _ -> Nothing
+ engine-src/Game/LambdaHack/Common/ItemAspect.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE DeriveGeneric #-}+-- | The type of item aspects and its operations.+module Game.LambdaHack.Common.ItemAspect+  ( AspectRecord(..), KindMean(..)+  , emptyAspectRecord, addMeanAspect, castAspect, aspectsRandom+  , aspectRecordToList, rollAspectRecord, getSkill, checkFlag, meanAspect+  , onlyMinorEffects, itemTrajectory, totalRange, isHumanTrinket+  , goesIntoEqp, loreFromContainer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , ceilingMeanDice+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Monad.Trans.State.Strict as St+import           Data.Binary+import qualified Data.EnumSet as ES+import           Data.Hashable (Hashable)+import qualified Data.Text as T+import           GHC.Generics (Generic)+import qualified System.Random.SplitMix32 as SM++import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | Record of skills conferred by an item as well as of item flags+-- and other item aspects.+data AspectRecord = AspectRecord+  { aTimeout   :: Int+  , aSkills    :: Ability.Skills+  , aFlags     :: Ability.Flags+  , aELabel    :: Text+  , aToThrow   :: IK.ThrowMod+  , aPresentAs :: Maybe (GroupName IK.ItemKind)+  , aEqpSlot   :: Maybe Ability.EqpSlot+  }+  deriving (Show, Eq, Ord, Generic)++instance Hashable AspectRecord++instance Binary AspectRecord++-- | Partial information about an item, deduced from its item kind.+-- These are assigned to each 'IK.ItemKind'. The @kmConst@ flag says whether+-- the item's aspect record is constant rather than random or dependent+-- on item creation dungeon level.+data KindMean = KindMean+  { kmConst :: Bool  -- ^ whether the item doesn't need second identification+  , kmMean  :: AspectRecord  -- ^ mean value of item's possible aspect records+  }+  deriving (Show, Eq, Ord)++emptyAspectRecord :: AspectRecord+emptyAspectRecord = AspectRecord+  { aTimeout = 0+  , aSkills = Ability.zeroSkills+  , aFlags = Ability.Flags ES.empty+  , aELabel = ""+  , aToThrow = IK.ThrowMod 100 100 1+  , aPresentAs = Nothing+  , aEqpSlot = Nothing+  }++castAspect :: Dice.AbsDepth -> Dice.AbsDepth -> AspectRecord -> IK.Aspect+           -> Rnd AspectRecord+castAspect !ldepth !totalDepth !ar !asp =+  case asp of+    IK.Timeout d -> do+      n <- castDice ldepth totalDepth d+      return $! assert (aTimeout ar == 0) $ ar {aTimeout = n}+    IK.AddSkill sk d -> do+      n <- castDice ldepth totalDepth d+      return $! if n /= 0+                then ar {aSkills = Ability.addSk sk n (aSkills ar)}+                else ar+    IK.SetFlag feat ->+      return $! ar {aFlags = Ability.Flags+                             $ ES.insert feat (Ability.flags $ aFlags ar)}+    IK.ELabel t -> return $! ar {aELabel = t}+    IK.ToThrow tt -> return $! ar {aToThrow = tt}+    IK.PresentAs ha -> return $! ar {aPresentAs = Just ha}+    IK.EqpSlot slot -> return $! ar {aEqpSlot = Just slot}+    IK.Odds d aspects1 aspects2 -> do+      pick1 <- oddsDice ldepth totalDepth d+      foldlM' (castAspect ldepth totalDepth) ar $+        if pick1 then aspects1 else aspects2++-- If @False@, aspects of this kind are most probably fixed, not random+-- nor dependent on dungeon level where the item is created.+aspectsRandom :: [IK.Aspect] -> Bool+aspectsRandom ass =+  let rollM depth =+        foldlM' (castAspect (Dice.AbsDepth depth) (Dice.AbsDepth 10))+                emptyAspectRecord ass+      gen = SM.mkSMGen 0+      (ar0, gen0) = St.runState (rollM 0) gen+      (ar1, gen1) = St.runState (rollM 10) gen0+  in show gen /= show gen0 || show gen /= show gen1 || ar0 /= ar1++addMeanAspect :: AspectRecord -> IK.Aspect -> AspectRecord+addMeanAspect !ar !asp =+  case asp of+    IK.Timeout d ->+      let n = ceilingMeanDice d+      in assert (aTimeout ar == 0) $ ar {aTimeout = n}+    IK.AddSkill sk d ->+      let n = ceilingMeanDice d+      in if n /= 0+         then ar {aSkills = Ability.addSk sk n (aSkills ar)}+         else ar+    IK.SetFlag feat ->+      ar {aFlags = Ability.Flags $ ES.insert feat (Ability.flags $ aFlags ar)}+    IK.ELabel t -> ar {aELabel = t}+    IK.ToThrow tt -> ar {aToThrow = tt}+    IK.PresentAs ha -> ar {aPresentAs = Just ha}+    IK.EqpSlot slot -> ar {aEqpSlot = Just slot}+    IK.Odds{} -> ar  -- can't tell, especially since we don't know the level++ceilingMeanDice :: Dice.Dice -> Int+ceilingMeanDice d = ceiling $ Dice.meanDice d++aspectRecordToList :: AspectRecord -> [IK.Aspect]+aspectRecordToList AspectRecord{..} =+  [IK.Timeout $ Dice.intToDice aTimeout | aTimeout /= 0]+  ++ [ IK.AddSkill sk $ Dice.intToDice n+     | (sk, n) <- Ability.skillsToList aSkills ]+  ++ [IK.SetFlag feat | feat <- ES.elems $ Ability.flags aFlags]+  ++ [IK.ELabel aELabel | not $ T.null aELabel]+  ++ [IK.ToThrow aToThrow | aToThrow /= IK.ThrowMod 100 100 1]+  ++ maybe [] (\ha -> [IK.PresentAs ha]) aPresentAs+  ++ maybe [] (\slot -> [IK.EqpSlot slot]) aEqpSlot++rollAspectRecord :: [IK.Aspect] -> Dice.AbsDepth -> Dice.AbsDepth+                 -> Rnd AspectRecord+rollAspectRecord ass ldepth totalDepth =+  foldlM' (castAspect ldepth totalDepth) emptyAspectRecord ass++getSkill :: Ability.Skill -> AspectRecord -> Int+{-# INLINE getSkill #-}+getSkill sk ar = Ability.getSk sk $ aSkills ar++checkFlag :: Ability.Flag -> AspectRecord -> Bool+{-# INLINE checkFlag #-}+checkFlag flag ar = Ability.checkFl flag (aFlags ar)++meanAspect :: IK.ItemKind -> AspectRecord+meanAspect kind = foldl' addMeanAspect emptyAspectRecord (IK.iaspects kind)++-- Kinetic damage is not considered major effect, even though it+-- identifies an item, when one hits with it. However, it's tedious+-- to wait for weapon identification until first hit and also+-- if a weapon is periodically activated, the kinetic damage would not apply,+-- so we'd need special cases that force identification or warn+-- or here not consider kinetic damage a major effect if item is periodic.+-- So we opt for KISS and identify effect-less weapons at pick-up,+-- not at first hit.+onlyMinorEffects :: AspectRecord -> IK.ItemKind -> Bool+onlyMinorEffects ar kind =+  checkFlag Ability.MinorEffects ar  -- override+  || all IK.alwaysDudEffect (IK.ieffects kind)+       -- exhibits no major effects++itemTrajectory :: AspectRecord -> IK.ItemKind -> [Point]+               -> ([Vector], (Speed, Int))+itemTrajectory ar itemKind path =+  let IK.ThrowMod{..} = aToThrow ar+  in computeTrajectory (IK.iweight itemKind) throwVelocity throwLinger path++totalRange :: AspectRecord -> IK.ItemKind -> Int+totalRange ar itemKind = snd $ snd $ itemTrajectory ar itemKind []++isHumanTrinket :: IK.ItemKind -> Bool+isHumanTrinket itemKind =+  maybe False (> 0) $ lookup IK.VALUABLE $ IK.ifreq itemKind+    -- risk from treasure hunters++goesIntoEqp :: AspectRecord -> Bool+goesIntoEqp ar = checkFlag Ability.Equipable ar+                 || checkFlag Ability.Meleeable ar++loreFromContainer :: AspectRecord -> Container -> SLore+loreFromContainer arItem c = case c of+  CFloor{} -> SItem+  CEmbed{} -> SEmbed+  CActor _ store -> if | checkFlag Ability.Blast arItem -> SBlast+                       | checkFlag Ability.Condition arItem -> SCondition+                       | otherwise -> loreFromMode $ MStore store+  CTrunk{} -> if checkFlag Ability.Blast arItem then SBlast else STrunk
+ engine-src/Game/LambdaHack/Common/JSFile.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE JavaScriptFFI #-}+-- | Saving/loading to JS storeage, mimicking operations on files.+module Game.LambdaHack.Common.JSFile+  (+#ifdef USE_JSFILE+-- to molify doctest, but don't break stylish-haskell parsing+    encodeEOF, strictDecodeEOF+  , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile+#endif+  ) where++#ifdef USE_JSFILE+import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Text as T+import           Data.Text.Encoding (decodeLatin1)+import           Data.Version++import qualified Data.JSString as JSString+import           Data.JSString.Text (textToJSString)+import           GHCJS.DOM (currentWindow)+import           GHCJS.DOM.Storage (getItem, removeItem, setItem)+import           GHCJS.DOM.Types (JSString, runDOM)+import           GHCJS.DOM.Window (getLocalStorage)++foreign import javascript safe "$r = LZString.compressToUTF16($1);"+  compressToUTF16 :: JSString -> IO JSString++foreign import javascript safe "$r = LZString.decompressFromUTF16($1);"+  decompressFromUTF16 :: JSString -> IO JSString++-- | Serialize and save data with an EOF marker, compressing.+-- We treat the bytestring as Latin1 characters and so ensure+-- we never run into illegal characters in the aribtrary binary data,+-- unlike when treating it as UTF16 characters. This is also reasonably fast.+-- The @OK@ is used as an EOF marker to ensure any apparent problems with+-- corrupted files are reported to the user ASAP.+encodeEOF :: Binary b => FilePath -> Version -> b -> IO ()+encodeEOF path v b = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  let t = decodeLatin1 $ LBS.toStrict $ encode (v, (encode b, "OK" :: String))+  item <- compressToUTF16 $ textToJSString t+  setItem storage path item++-- | Read and deserialize data with an EOF marker.+-- The @OK@ EOF marker ensures any easily detectable file corruption+-- is discovered and reported before any value is decoded from+-- the second component.+-- OTOH, binary encoding corruption is not discovered until a version+-- check elsewhere ensures that binary formats are compatible.+strictDecodeEOF :: Binary b => FilePath -> IO (Version, b)+strictDecodeEOF path = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  Just item <- getItem storage path+  t <- decompressFromUTF16 item+  -- TODO: is @LBS.toLazy . encodeUtf8 . textFromJSString@ faster and correct?+  let c1 = LBS.pack $ JSString.unpack t+      (v1, (c2, s)) = decode c1+  return $! if s == ("OK" :: String)+            then (v1, decode c2)+            else error $ "Fatal error: corrupted file " ++ path++-- | Try to create a directory; not needed with local storage in JS.+tryCreateDir :: FilePath -> IO ()+tryCreateDir _dir = return ()++doesFileExist :: FilePath -> IO Bool+doesFileExist path = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  let fileExists = isJust (mitem :: Maybe String)+  return $! fileExists++tryWriteFile :: FilePath -> String -> IO ()+tryWriteFile path content = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  let fileExists = isJust (mitem :: Maybe String)+  unless fileExists $+    setItem storage path $ T.unpack content++readFile :: FilePath -> IO String+readFile path = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  case mitem of+    Nothing -> fail $ "Fatal error: no file " ++ path+    Just item -> return item++renameFile :: FilePath -> FilePath -> IO ()+renameFile path path2 = flip runDOM undefined $ do+  Just win <- currentWindow+  storage <- getLocalStorage win+  mitem <- getItem storage path+  case mitem :: Maybe String of+    Nothing -> fail $ "Fatal error: no file " ++ path+    Just item -> do+      setItem storage path2 item  -- overwrites+      removeItem storage path+#endif
+ engine-src/Game/LambdaHack/Common/Kind.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE TupleSections #-}+-- | General content types and operations.+module Game.LambdaHack.Common.Kind+  ( ContentData  -- re-exported without some operations+  , COps(..)+  , emptyCOps+  , ItemSpeedup+  , getKindMean, speedupItem+  , okind, omemberGroup, oisSingletonGroup, ouniqGroup, opick+  , ofoldlWithKey', ofoldlGroup', omapVector, oimapVector+  , olength, linearInterpolation, emptyMultiGroupMode, emptyMultiGroupItem+#ifdef EXPOSE_INTERNAL+  , emptyUnknownTile+  , emptyUIFactionGroupName+#endif+    -- * Operations both internal and used in unit tests+  , emptyUIFaction+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Vector as V++import qualified Game.LambdaHack.Common.ItemAspect as IA+import qualified Game.LambdaHack.Common.Tile as Tile+import qualified Game.LambdaHack.Content.CaveKind as CK+import qualified Game.LambdaHack.Content.FactionKind as FK+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.ModeKind as MK+import qualified Game.LambdaHack.Content.PlaceKind as PK+import qualified Game.LambdaHack.Content.RuleKind as RK+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.ContentData+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.DefsInternal+  (GroupName (GroupName), toContentSymbol)+import           Game.LambdaHack.Definition.Flavour (dummyFlavour)++-- | Operations for all content types, gathered together.+--+-- Warning: this type is not abstract, but its values should not be+-- created ad hoc, even for unit tests, but should be constructed+-- with @makeData@ for each particular content kind, which includes validation,+-- and with @speedupItem@, etc., to ensure internal consistency.+--+-- The @emptyCOps@ is one such valid by construction value of this type,+-- except for the @cocave@ field. It's suitable for bootstrapping+-- and for tests not involving dungeon generation from cave templates.+data COps = COps+  { cocave        :: ContentData CK.CaveKind   -- server only+  , cofact        :: ContentData FK.FactionKind+  , coitem        :: ContentData IK.ItemKind+  , comode        :: ContentData MK.ModeKind   -- server only+  , coplace       :: ContentData PK.PlaceKind  -- server only, so far+  , corule        :: RK.RuleContent+  , cotile        :: ContentData TK.TileKind+  , coItemSpeedup :: ItemSpeedup+  , coTileSpeedup :: Tile.TileSpeedup+  }++instance Show COps where+  show _ = "game content"++instance Eq COps where+  (==) _ _ = True++emptyMultiGroupItem :: IK.ItemKind+emptyMultiGroupItem = IK.ItemKind+  { isymbol  = toContentSymbol 'E'+  , iname    = "emptyCOps item"+  , ifreq    = map (, 1) $ IK.mandatoryGroups ++ IK.mandatoryGroupsSingleton+  , iflavour = [dummyFlavour]+  , icount   = 0+  , irarity  = []+  , iverbHit = ""+  , iweight  = 0+  , idamage  = 0+  , iaspects = []+  , ieffects = []+  , idesc    = ""+  , ikit     = []+  }++emptyUnknownTile :: TK.TileKind+emptyUnknownTile = TK.TileKind  -- needs to have index 0 and alter 1+  { tsymbol  = 'E'+  , tname    = "unknown space"  -- name checked in validation+  , tfreq    = map (, 1) $ TK.mandatoryGroups ++ TK.mandatoryGroupsSingleton+  , tcolor   = Color.BrMagenta+  , tcolor2  = Color.BrMagenta+  , talter   = 1+  , tfeature = []+  }++emptyUIFactionGroupName :: GroupName FK.FactionKind+emptyUIFactionGroupName = GroupName "emptyUIFaction"++emptyUIFaction :: FK.FactionKind+emptyUIFaction = FK.FactionKind+  { fname = "emptyUIFaction"+  , ffreq = [(emptyUIFactionGroupName, 1)]+  , fteam = FK.TeamContinuity 999  -- must be > 0+  , fgroups = []+  , fskillsOther = Ability.zeroSkills+  , fcanEscape = False+  , fneverEmpty = True  -- to keep the dungeon alive+  , fhiCondPoly = []+  , fhasGender = False+  , finitDoctrine = Ability.TBlock+  , fspawnsFast = False+  , fhasPointman = False+  , fhasUI = True  -- to own the UI frontend+  , finitUnderAI = False+  , fenemyTeams = []+  , falliedTeams = []+  }++emptyMultiGroupMode :: MK.ModeKind+emptyMultiGroupMode = MK.ModeKind+  { mname   = "emptyMultiGroupMode"+  , mfreq   = map (, 1) MK.mandatoryGroups+  , mtutorial = False+  , mattract = False+  , mroster = [(emptyUIFactionGroupName, [])]+  , mcaves  = []+  , mendMsg = []+  , mrules  = ""+  , mdesc   = ""+  , mreason = ""+  , mhint   = ""+  }++-- | This is as empty, as possible, but still valid content, except for+-- @cocave@ which is empty and not valid (making it valid would require+-- bloating most other contents).+emptyCOps :: COps+emptyCOps =+  let corule = RK.emptyRuleContent+      coitem = IK.makeData (RK.ritemSymbols corule) [emptyMultiGroupItem] [] []+      cotile = TK.makeData [emptyUnknownTile] [] []+      cofact = FK.makeData [emptyUIFaction] [emptyUIFactionGroupName] []+  in COps+    { cocave = emptyContentData  -- not valid! beware when testing!+        -- to make valid cave content, we'd need to define a single cave kind,+        -- which involves creating and validating tile and place kinds, etc.+    , cofact+    , coitem+    , comode = MK.makeData cofact [emptyMultiGroupMode] [] []+    , coplace = PK.makeData cotile [] [] []+    , corule+    , cotile+    , coItemSpeedup = speedupItem coitem+    , coTileSpeedup = Tile.speedupTile False cotile+    }++-- | Map from an item kind identifier to the mean aspect value for the kind.+newtype ItemSpeedup = ItemSpeedup (V.Vector IA.KindMean)++getKindMean :: ContentId IK.ItemKind -> ItemSpeedup -> IA.KindMean+getKindMean kindId (ItemSpeedup is) = is V.! contentIdIndex kindId++speedupItem :: ContentData IK.ItemKind -> ItemSpeedup+speedupItem coitem =+  let f !kind =+        let kmMean = IA.meanAspect kind+            kmConst = not $ IA.aspectsRandom (IK.iaspects kind)+        in IA.KindMean{..}+  in ItemSpeedup $ omapVector coitem f
+ engine-src/Game/LambdaHack/Common/Level.hs view
@@ -0,0 +1,356 @@+-- | Inhabited dungeon levels and the operations to query and change them+-- as the game progresses.+module Game.LambdaHack.Common.Level+  ( -- * Dungeon+    Dungeon, dungeonBounds, ascendInBranch, whereTo+    -- * The @Level@ type and its components+  , ItemFloor, BigActorMap, ProjectileMap, TileMap, SmellMap, Level(..)+    -- * Component updates+  , updateFloor, updateEmbed, updateBigMap, updateProjMap+  , updateTile, updateEntry, updateSmell+    -- * Level query+  , at+  , posToBigLvl, occupiedBigLvl, posToProjsLvl, occupiedProjLvl, posToAidsLvl+  , findPosTry, findPosTry2, nearbyPassablePoints, nearbyFreePoints+    -- * Misc+  , sortEmbeds+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , EntryMap+  , assertSparseItems, assertSparseProjectiles+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.CaveKind (CaveKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.PlaceKind+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.Defs++-- | The complete dungeon is a map from level identifiers to levels.+type Dungeon = EM.EnumMap LevelId Level++dungeonBounds :: Dungeon -> (LevelId, LevelId)+dungeonBounds dungeon+  | Just ((s, _), _) <- EM.minViewWithKey dungeon+  , Just ((e, _), _) <- EM.maxViewWithKey dungeon+  = (s, e)+dungeonBounds dungeon = error $ "empty dungeon" `showFailure` dungeon++-- | Levels in the current branch, one level up (or down) from the current.+ascendInBranch :: Dungeon -> Bool -> LevelId -> [LevelId]+ascendInBranch dungeon up lid =+  -- Currently there is just one branch, so the computation is simple.+  let (minD, maxD) = dungeonBounds dungeon+      ln = max minD $ min maxD $ toEnum $ fromEnum lid + if up then 1 else -1+  in case EM.lookup ln dungeon of+    Just _ | ln /= lid -> [ln]+    _ | ln == lid -> []+    _ -> ascendInBranch dungeon up ln  -- jump over gaps++-- | Compute the level identifier and stair position on the new level,+-- after a level change.+--+-- We assume there is never a staircase up and down at the same position.+whereTo :: LevelId             -- ^ level of the stairs+        -> Point               -- ^ position of the stairs+        -> Bool                -- ^ optional forced direction+        -> Dungeon             -- ^ current game dungeon+        -> [(LevelId, Point)]  -- ^ possible destinations+whereTo lid pos up dungeon =+  let lvl = dungeon EM.! lid+      li = case elemIndex pos $ fst $ lstair lvl of+        Just ifst -> assert up [ifst]+        Nothing -> case elemIndex pos $ snd $ lstair lvl of+          Just isnd -> assert (not up) [isnd]+          Nothing ->+            let forcedPoss = (if up then fst else snd) (lstair lvl)+            in [0 .. length forcedPoss - 1]  -- for ascending via, e.g., spells+  in case ascendInBranch dungeon up lid of+    [] -> []  -- spell fizzles+    ln : _ -> let lvlDest = dungeon EM.! ln+                  stairsDest = (if up then snd else fst) (lstair lvlDest)+                  posAtIndex i = case drop i stairsDest of+                    [] -> error $ "not enough stairs:" `showFailure` (ln, i + 1)+                    p : _ -> (ln, p)+              in map posAtIndex li++-- | Items located on map tiles.+type ItemFloor = EM.EnumMap Point ItemBag++-- | Big actors located on map tiles.+type BigActorMap = EM.EnumMap Point ActorId++-- | Collections of projectiles located on map tiles.+type ProjectileMap = EM.EnumMap Point [ActorId]++-- | Tile kinds on the map.+type TileMap = PointArray.Array (ContentId TileKind)++-- | Current smell on map tiles.+type SmellMap = EM.EnumMap Point Time++-- | Entries of places on the map.+type EntryMap = EM.EnumMap Point PlaceEntry++-- | A view on single, inhabited dungeon level. "Remembered" fields+-- carry a subset of the info in the client copies of levels.+data Level = Level+  { lkind   :: ContentId CaveKind+                          -- ^ the kind of cave the level is an instance of+  , ldepth  :: Dice.AbsDepth+                          -- ^ absolute depth of the level+  , lfloor  :: ItemFloor  -- ^ remembered items lying on the floor+  , lembed  :: ItemFloor  -- ^ remembered items embedded in the tile+  , lbig    :: BigActorMap+                          -- ^ seen big (non-projectile) actors at positions+                          --   on the level;+                          --   could be recomputed at resume, but small enough+  , lproj   :: ProjectileMap+                          -- ^ seen projectiles at positions on the level;+                          --   could be recomputed at resume+  , ltile   :: TileMap    -- ^ remembered level map+  , lentry  :: EntryMap   -- ^ room entrances on the level+  , larea   :: Area       -- ^ area of the level+  , lsmell  :: SmellMap   -- ^ remembered smells on the level+  , lstair  :: ([Point], [Point])+                          -- ^ positions of (up, down) stairs+  , lescape :: [Point]    -- ^ positions of IK.Escape tiles+  , lseen   :: Int        -- ^ currently remembered clear tiles+  , lexpl   :: Int        -- ^ total number of explorable tiles+  , ltime   :: Time       -- ^ local time on the level (possibly frozen)+  , lnight  :: Bool       -- ^ whether the level is covered in darkness+  }+  deriving (Show, Eq)++assertSparseItems :: ItemFloor -> ItemFloor+assertSparseItems m =+  assert (EM.null (EM.filter EM.null m)+          `blame` "null floors found" `swith` m) m++hashConsSingle :: ItemFloor -> ItemFloor+hashConsSingle =+  EM.map (EM.map (\case+                    (1, []) -> quantSingle+                    kit -> kit))++assertSparseProjectiles :: ProjectileMap -> ProjectileMap+assertSparseProjectiles m =+  assert (EM.null (EM.filter null m)+          `blame` "null projectile lists found" `swith` m) m++updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level+{-# INLINE updateFloor #-}  -- just in case inliner goes hiwire+updateFloor f lvl = lvl {lfloor = f (lfloor lvl)}++updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level+updateEmbed f lvl = lvl {lembed = f (lembed lvl)}++updateBigMap :: (BigActorMap -> BigActorMap) -> Level -> Level+updateBigMap f lvl = lvl {lbig = f (lbig lvl)}++updateProjMap :: (ProjectileMap -> ProjectileMap) -> Level -> Level+{-# INLINE updateProjMap #-}+updateProjMap f lvl = lvl {lproj = f (lproj lvl)}++updateTile :: (TileMap -> TileMap) -> Level -> Level+updateTile f lvl = lvl {ltile = f (ltile lvl)}++updateEntry :: (EntryMap -> EntryMap) -> Level -> Level+updateEntry f lvl = lvl {lentry = f (lentry lvl)}++updateSmell :: (SmellMap -> SmellMap) -> Level -> Level+updateSmell f lvl = lvl {lsmell = f (lsmell lvl)}++-- | Query for tile kinds on the map.+at :: Level -> Point -> ContentId TileKind+{-# INLINE at #-}+at Level{ltile} p = ltile PointArray.! p++posToBigLvl :: Point -> Level -> Maybe ActorId+{-# INLINE posToBigLvl #-}+posToBigLvl pos lvl = EM.lookup pos $ lbig lvl++occupiedBigLvl :: Point -> Level -> Bool+{-# INLINE occupiedBigLvl #-}+occupiedBigLvl pos lvl = pos `EM.member` lbig lvl++posToProjsLvl :: Point -> Level -> [ActorId]+{-# INLINE posToProjsLvl #-}+posToProjsLvl pos lvl = EM.findWithDefault [] pos $ lproj lvl++occupiedProjLvl :: Point -> Level -> Bool+{-# INLINE occupiedProjLvl #-}+occupiedProjLvl pos lvl = pos `EM.member` lproj lvl++posToAidsLvl :: Point -> Level -> [ActorId]+{-# INLINE posToAidsLvl #-}+posToAidsLvl pos lvl = maybeToList (posToBigLvl pos lvl)+                       ++ posToProjsLvl pos lvl++-- | Try to find a random position on the map satisfying+-- conjunction of the mandatory and an optional predicate.+-- If the permitted number of attempts is not enough,+-- try again the same number of times without the next optional predicate,+-- and fall back to trying with only the mandatory predicate.+findPosTry :: Int                                    -- ^ the number of tries+           -> Level                                  -- ^ look up in this level+           -> (Point -> ContentId TileKind -> Bool)  -- ^ mandatory predicate+           -> [Point -> ContentId TileKind -> Bool]  -- ^ optional predicates+           -> Rnd (Maybe Point)+{-# INLINE findPosTry #-}+findPosTry numTries lvl m = findPosTry2 numTries lvl m [] undefined++findPosTry2 :: Int                                    -- ^ the number of tries+            -> Level                                  -- ^ look up in this level+            -> (Point -> ContentId TileKind -> Bool)  -- ^ mandatory predicate+            -> [Point -> ContentId TileKind -> Bool]  -- ^ optional predicates+            -> (Point -> ContentId TileKind -> Bool)  -- ^ good to have pred.+            -> [Point -> ContentId TileKind -> Bool]  -- ^ worst case predicates+            -> Rnd (Maybe Point)+{-# INLINE findPosTry2 #-}+findPosTry2 numTries Level{ltile, larea} m0 l g r =+  assert (numTries > 0) $+  let (Point x0 y0, xspan, yspan) = spanArea larea+      accomodate :: Rnd (Maybe Point)+                 -> (Point -> ContentId TileKind -> Bool)+                 -> [Point -> ContentId TileKind -> Bool]+                 -> Rnd (Maybe Point)+      {-# INLINE accomodate #-}+      accomodate fallback m = go+       where+        go :: [Point -> ContentId TileKind -> Bool]+           -> Rnd (Maybe Point)+        go [] = fallback+        go (hd : tl) = search numTries+         where+          search 0 = go tl+          search !k = do+            pxyRelative <- randomR0 (xspan * yspan - 1)+            -- Here we can't use @fromEnum@ and/or work with the @Int@+            -- representation, because the span is different than @rWidthMax@.+            let Point{..} = punindex xspan pxyRelative+                pos = Point (x0 + px) (y0 + py)+                tile = ltile PointArray.! pos+            if m pos tile && hd pos tile+            then return $ Just pos+            else search (k - 1)+      rAndOnceOnlym0 = r ++ [\_ _ -> True]+  in accomodate (accomodate (return Nothing) m0 rAndOnceOnlym0)+                -- @pos@ and @tile@ not always needed, so not strict;+                -- the function arguments determine that thanks to inlining.+                (\pos tile -> m0 pos tile && g pos tile)+                l++-- | Generate a list of all passable points on (connected component of)+-- the level in the order of path distance from the starting position (BFS).+-- The starting position needn't be passable and is always included.+nearbyPassablePoints :: COps -> Level -> Point -> [Point]+nearbyPassablePoints cops@COps{corule=RuleContent{rWidthMax, rHeightMax}}+                     lvl start =+  let passable p = Tile.isEasyOpen (coTileSpeedup cops) (lvl `at` p)+      -- The error is mostly probably caused by place content creating+      -- enclosed spaces in conjunction with map edges. To verify,+      -- change the error to @l@ and run with the same seed.+      semiRandomWrap l = if null l then error "nearbyPassablePoints: blocked"+                         else let offset = fromEnum start `mod` length l+                              in drop offset l ++ take offset l+      passableVic p = semiRandomWrap $ filter passable+                      $ vicinityBounded rWidthMax rHeightMax p+      siftSingle :: Point+                 -> (ES.EnumSet Point, [Point])+                 -> (ES.EnumSet Point, [Point])+      siftSingle current (seen, sameDistance) =+        if current `ES.member` seen+        then (seen, sameDistance)+        else (ES.insert current seen, current : sameDistance)+      siftVicinity :: Point+                   -> (ES.EnumSet Point, [Point])+                   -> (ES.EnumSet Point, [Point])+      siftVicinity current seenAndSameDistance =+        let vic = passableVic current+        in foldr siftSingle seenAndSameDistance vic+      siftNearby :: (ES.EnumSet Point, [Point]) -> [Point]+      siftNearby (seen, sameDistance) =+        sameDistance+        ++ case foldr siftVicinity (seen, []) sameDistance of+             (_, []) -> []+             (seen2, sameDistance2) -> siftNearby (seen2, sameDistance2)+  in siftNearby (ES.singleton start, [start])++nearbyFreePoints :: COps -> Level -> (ContentId TileKind -> Bool) -> Point+                 -> [Point]+nearbyFreePoints cops lvl f start =+  let good p = f (lvl `at` p)+               && Tile.isWalkable (coTileSpeedup cops) (lvl `at` p)+               && null (posToAidsLvl p lvl)+  in filter good $ nearbyPassablePoints cops lvl start++-- We ignore stray embeds, not mentioned in the tile kind.+-- OTOH, some of those mentioned may be used up and so not in the bag+-- and it's OK.+sortEmbeds :: COps -> ContentId TileKind -> [(IK.ItemKind, (ItemId, ItemQuant))]+           -> [(ItemId, ItemQuant)]+sortEmbeds COps{cotile} tk embedKindList =+  let grpList = Tile.embeddedItems cotile tk+      -- Greater or equal 0 to also cover template UNKNOWN items+      -- not yet identified by the client.+      f grp (itemKind, _) = fromMaybe (-1) (lookup grp $ IK.ifreq itemKind) >= 0+  in map snd $ mapMaybe (\grp -> find (f grp) embedKindList) grpList++instance Binary Level where+  put Level{..} = do+    put lkind+    put ldepth+    put (assertSparseItems lfloor)+    put (assertSparseItems lembed)+    put lbig+    put (assertSparseProjectiles lproj)+    put ltile+    put lentry+    put larea+    put lsmell+    put lstair+    put lescape+    put lseen+    put lexpl+    put ltime+    put lnight+  get = do+    lkind <- get+    ldepth <- get+    lfloor <- hashConsSingle <$> get+    lembed <- hashConsSingle <$> get+    lbig <- get+    lproj <- get+    ltile <- get+    lentry <- get+    larea <- get+    lsmell <- get+    lstair <- get+    lescape <- get+    lseen <- get+    lexpl <- get+    ltime <- get+    lnight <- get+    return $! Level{..}
+ engine-src/Game/LambdaHack/Common/Misc.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Hacks that haven't found their home yet.+module Game.LambdaHack.Common.Misc+  ( FontDefinition(..), HintingMode(..), FontSet(..)+  , makePhrase, makeSentence, squashedWWandW+  , appDataDir+  , xM, xD, minusM, minusM1, minusM2, oneM, tenthM+  , show64With2+  , workaroundOnMainThreadMVar+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import           Control.DeepSeq+import           Data.Binary+import qualified Data.Char as Char+import           Data.Int (Int64)+import qualified Data.Map as M+import           GHC.Generics (Generic)+import qualified NLP.Miniutter.English as MU+import           System.Directory (getAppUserDataDirectory)+import           System.Environment (getProgName)+import           System.IO.Unsafe (unsafePerformIO)++data FontDefinition =+    FontProportional Text Int HintingMode  -- ^ filename, size, hinting mode+  | FontMonospace Text Int HintingMode+  | FontMapScalable Text Int HintingMode Int  -- ^ extra cell extension+  | FontMapBitmap Text Int  -- ^ size ignored for bitmap fonts and no hinting+  deriving (Show, Eq, Read, Generic)++instance NFData FontDefinition++instance Binary FontDefinition++data HintingMode =+    HintingHeavy  -- ^ current libfreetype6 default, thin, large letter spacing+  | HintingLight  -- ^ mimics OTF, blurry, thick, tight tracking, accurate shape+  deriving (Show, Eq, Read, Generic)++instance NFData HintingMode++instance Binary HintingMode++data FontSet = FontSet+  { fontMapScalable :: Text+  , fontMapBitmap   :: Text+  , fontPropRegular :: Text+  , fontPropBold    :: Text+  , fontMono        :: Text }+  deriving (Show, Eq, Read, Generic)++instance NFData FontSet++instance Binary FontSet++-- | Re-exported English phrase creation functions, applied to our custom+-- irregular word sets.+makePhrase, makeSentence :: [MU.Part] -> Text+makePhrase = MU.makePhrase irregular+makeSentence = MU.makeSentence irregular++irregular :: MU.Irregular+irregular = MU.Irregular+  { irrPlural =+      M.fromList+        [ ("merchandise", "merchandise")+        , ("Merchandise", "Merchandise")+        , ("stomach", "stomachs") ]+            -- this is both countable and uncountable, but I use it here+            -- only as uncountable, do I overwrite the default+      `M.union` MU.irrPlural MU.defIrregular+  , irrIndefinite = MU.irrIndefinite MU.defIrregular+  }++-- | Apply the @WWandW@ constructor, first representing repetitions+-- as @CardinalWs@.+-- The parts are not sorted, only grouped, to keep the order.+-- The internal structure of speech parts is compared, not their string+-- rendering, so some coincidental clashes are avoided (and code is simpler).+squashedWWandW :: [MU.Part] -> (MU.Part, MU.Person)+squashedWWandW parts =+  let repetitions = group parts+      f [] = error $ "empty group" `showFailure` parts+      f [part] = (part, MU.Sg3rd)  -- avoid prefixing hero names with "a"+      f l@(part : _) = (MU.CardinalWs (length l) part, MU.PlEtc)+      cars = map f repetitions+      person = case cars of+        [] -> error $ "empty cars" `showFailure` parts+        [(_, person1)] -> person1+        _ -> MU.PlEtc+  in (MU.WWandW $ map fst cars, person)++-- | 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++-- | Multiplies by a million.+xM :: Int -> Int64+xM k = into @Int64 k * 1000000++-- | Multiplies by a million, double precision.+xD :: Double -> Double+xD k = k * 1000000++minusM, minusM1, minusM2, oneM, tenthM :: Int64+minusM = xM (-1)+minusM1 = xM (-1) - 1+minusM2 = xM (-1) - 2+oneM = xM 1+tenthM = 100000++show64With2 :: Int64 -> Text+show64With2 n =+  let k = 100 * n `divUp` oneM+      l = k `div` 100+      x = k - l * 100+      y = x `div` 10+  in tshow l+     <> if | x == 0 -> ""+           | x == y * 10 -> "." <> tshow y+           | x < 10 -> ".0" <> tshow x+           | otherwise -> "." <> tshow x++-- Global variable for passing the action to run on main thread, if any.+workaroundOnMainThreadMVar :: MVar (IO ())+{-# NOINLINE workaroundOnMainThreadMVar #-}+workaroundOnMainThreadMVar = unsafePerformIO newEmptyMVar
+ engine-src/Game/LambdaHack/Common/MonadStateRead.hs view
@@ -0,0 +1,131 @@+-- | Game state reading monad and basic operations.+module Game.LambdaHack.Common.MonadStateRead+  ( MonadStateRead(..)+  , getState, getLevel+  , getGameMode, isNoConfirmsGame, getEntryArena, pickWeaponM, displayTaunt+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Either+import qualified Data.EnumMap.Strict as EM++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability++-- | Monad for reading game state. A state monad with state modification+-- disallowed (another constraint is needed to permit that).+-- The basic server and client monads are like that, because server+-- and clients freely modify their internal session data, but don't modify+-- the main game state, except in very restricted and synchronized way.+class (Monad m, Functor m, Applicative m) => MonadStateRead m where+  getsState :: (State -> a) -> m a++getState :: MonadStateRead m => m State+getState = getsState id++getLevel :: MonadStateRead m => LevelId -> m Level+getLevel lid = getsState $ (EM.! lid) . sdungeon++getGameMode :: MonadStateRead m => m ModeKind+getGameMode = do+  COps{comode} <- getsState scops+  gameModeId <- getsState sgameModeId+  return $! okind comode gameModeId++isNoConfirmsGame :: MonadStateRead m => m Bool+isNoConfirmsGame = do+  gameMode <- getGameMode+  return $! mattract gameMode++getEntryArena :: MonadStateRead m => Faction -> m LevelId+getEntryArena fact = do+  dungeon <- getsState sdungeon+  let (minD, maxD) = dungeonBounds dungeon+      f [] = 0+      f ((ln, _, _) : _) = ln+  return $! max minD $ min maxD $ toEnum $ f $ ginitial fact++pickWeaponM :: MonadStateRead m+            => Bool -> Maybe DiscoveryBenefit+            -> [(ItemId, ItemFullKit)] -> Ability.Skills -> ActorId+            -> m [(Double, Bool, Int, Int, ItemId, ItemFullKit)]+pickWeaponM ignoreCharges mdiscoBenefit kitAss actorSk source = do+  sb <- getsState $ getActorBody source+  localTime <- getsState $ getLocalTime (blid sb)+  actorMaxSk <- getsState $ getActorMaxSkills source+  let calmE = calmEnough sb actorMaxSk+      forced = bproj sb+      permitted = permittedPrecious forced calmE+      preferredPrecious = fromRight False . permitted+      permAssocs = filter (preferredPrecious . fst . snd) kitAss+      strongest = strongestMelee ignoreCharges mdiscoBenefit+                                 localTime permAssocs+  return $! if | forced -> map (\(iid, itemFullKit) ->+                                  (-1, False, 0, 1, iid, itemFullKit)) kitAss+               | Ability.getSk Ability.SkMelee actorSk <= 0 -> []+               | otherwise -> strongest++displayTaunt :: MonadStateRead m+             => Bool -> (Rnd (Text, Text) -> m (Text, Text))+             -> ActorId -> m (Text, Text)+displayTaunt _voluntary rndToAction aid = do+  b <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let canApply = Ability.getSk Ability.SkApply actorMaxSk > 2+                 && canHear+        -- if applies complex items, probably intelligent and can speak+      canHear = Ability.getSk Ability.SkHearing actorMaxSk > 0+                && canBrace+        -- if hears, probably also emits sound vocally;+        -- disabled even by ushanka and rightly so+      canBrace = Ability.getSk Ability.SkWait actorMaxSk >= 2+        -- not an insect, plant, geyser, faucet, fence, etc.+        -- so can emit sound by hitting something with body parts+                 || Ability.getSk Ability.SkApply actorMaxSk > 2+                      -- and neither an impatient intelligent actor+      braceUneasy = [ (2, ("something", "flail around"))+                    , (1, ("something", "toss blindly"))+                    , (1, ("something", "squirm dizzily")) ]+      braceEasy = [ (2, ("something", "stretch"))+                  , (1, ("something", "fidget"))+                  , (1, ("something", "fret")) ]+      uneasy = deltasSerious (bcalmDelta b) || not (calmEnough b actorMaxSk)+  if bwatch b `elem` [WSleep, WWake]+  then rndToAction $ frequency $ toFreq "SfxTaunt" $+    if uneasy+    then if | canApply -> (5, ("somebody", "yell"))+                          : (3, ("somebody", "bellow"))+                          : braceUneasy+            | canHear -> (5, ("somebody", "bellow"))+                         : (3, ("something", "hiss"))+                         : braceUneasy+            | canBrace -> braceUneasy+            | otherwise -> [(1, ("something", "drone enquiringly"))]+    else if | canApply -> (5, ("somebody", "yawn"))+                          : (3, ("somebody", "grunt"))+                          : braceEasy+            | canHear -> (5, ("somebody", "grunt"))+                         : (3, ("something", "wheeze"))+                         : braceEasy+            | canBrace -> braceEasy+            | otherwise -> [(1, ("something", "hum silently"))]+  else return $!+    if | bproj b -> ("something", "ping")+       | canApply -> ("somebody", "holler a taunt")+       | canHear -> ("somebody", "growl menacingly")+       | canBrace -> ("something", "stomp repeatedly")+       | otherwise -> ("something", "buzz angrily")
+ engine-src/Game/LambdaHack/Common/Perception.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Actors perceiving other actors and the dungeon level.+--+-- Visibility works according to KISS. Everything that player sees is real.+-- There are no unmarked hidden tiles and only solid tiles can be marked,+-- so there are no invisible walls and to pass through an illusory wall,+-- you have to use a turn bumping into it first. Only tiles marked with Suspect+-- can turn out to be another tile. (So, if all tiles are marked with+-- Suspect, the player knows nothing for sure, but this should be avoided,+-- because searching becomes too time-consuming.)+-- Each actor sees adjacent tiles, even when blind, so adjacent tiles are+-- known, so the actor can decide accurately whether to pass thorugh+-- or alter, etc.+--+-- Items are always real and visible. Actors are real, but can be invisible.+-- Invisible actors in walls can't be hit, but are hinted at when altering+-- the tile, so the player can flee or block. Invisible actors in open+-- space can be hit.+module Game.LambdaHack.Common.Perception+  ( PerVisible(..)+  , PerSmelled(..)+  , Perception(..)+  , PerLid+  , PerFid+  , totalVisible, totalSmelled+  , emptyPer, nullPer, addPer, diffPer+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           GHC.Generics (Generic)++import Game.LambdaHack.Common.Types+import Game.LambdaHack.Common.Point++-- | Visible positions.+newtype PerVisible = PerVisible {pvisible :: ES.EnumSet Point}+  deriving (Show, Eq, Binary)++-- | Smelled positions.+newtype PerSmelled = PerSmelled {psmelled :: ES.EnumSet Point}+  deriving (Show, Eq, Binary)++-- | The type representing the perception of a faction on a level.+data Perception = Perception+  { psight :: PerVisible+  , psmell :: PerSmelled+  }+  deriving (Show, Eq, Generic)++instance Binary Perception++-- | Perception of a single faction, indexed by level identifier.+type PerLid = EM.EnumMap LevelId Perception++-- | Perception indexed by faction identifier.+-- This can't be added to @FactionDict@, because clients can't see it+-- for other factions.+type PerFid = EM.EnumMap FactionId PerLid++-- | The set of tiles visible by at least one hero.+totalVisible :: Perception -> ES.EnumSet Point+totalVisible = pvisible . psight++-- | The set of tiles smelt by at least one hero.+totalSmelled :: Perception -> ES.EnumSet Point+totalSmelled = psmelled . psmell++emptyPer :: Perception+emptyPer = Perception { psight = PerVisible ES.empty+                      , psmell = PerSmelled ES.empty }++nullPer :: Perception -> Bool+nullPer per = per == emptyPer++addPer :: Perception -> Perception -> Perception+addPer per1 per2 =+  Perception+    { psight = PerVisible+               $ totalVisible per1 `ES.union` totalVisible per2+    , psmell = PerSmelled+               $ totalSmelled per1 `ES.union` totalSmelled per2+    }++diffPer :: Perception -> Perception -> Perception+diffPer per1 per2 =+  Perception+    { psight = PerVisible+               $ totalVisible per1 ES.\\ totalVisible per2+    , psmell = PerSmelled+               $ totalSmelled per1 ES.\\ totalSmelled per2+    }
+ engine-src/Game/LambdaHack/Common/Point.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Basic operations on 2D points represented as linear offsets.+module Game.LambdaHack.Common.Point+  ( Point(..), PointI+  , chessDist, euclidDistSq, adjacent, bresenhamsLineAlgorithm, fromTo+  , originPoint, insideP+  , speedupHackXSize+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , bresenhamsLineAlgorithmBegin, balancedWord+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import           Data.Int (Int32)+import qualified Data.Primitive.PrimArray as PA+import           GHC.Generics (Generic)+import           Test.QuickCheck++import Game.LambdaHack.Definition.Defs++-- | This is a hack to pass the X size of the dungeon, defined+-- in game content, to the @Enum@ instances of @Point@ and @Vector@.+-- This is already slower and has higher allocation than+-- hardcoding the value, so passing the value explicitly to+-- a generalization of the @Enum@ conversions is out of the question.+-- Perhaps this can be done cleanly and efficiently at link-time+-- via Backpack, but it's probably not supported yet by GHCJS (not verified).+-- For now, we need to be careful never to modify this array,+-- except for setting it at program start before it's used for the first time.+-- Which is easy, because @Point@ is never mentioned in content definitions.+-- The @PrimArray@ has much smaller overhead than @IORef@+-- and reading from it looks cleaner, hence its use.+speedupHackXSize :: PA.PrimArray X+{-# NOINLINE speedupHackXSize #-}+speedupHackXSize = PA.primArrayFromList [80]  -- updated at program startup++-- | 2D points in cartesian representation. Coordinates grow to the right+-- and down, so that the (0, 0) point is in the top-left corner+-- of the screen. Coordinates are never negative+-- (unlike for 'Game.LambdaHack.Common.Vector.Vector')+-- and the @X@ coordinate never reaches the screen width as read+-- from 'speedupHackXSize'.+data Point = Point+  { px :: X+  , py :: Y+  }+  deriving (Eq, Ord, Generic)++instance Show Point where+  show (Point x y) = show (x, y)++instance Binary Point where+  put = put . (toIntegralCrash :: Int -> Int32) . fromEnum+  get = fmap (toEnum . (fromIntegralWrap :: Int32 -> Int)) get+    -- `fromIntegralWrap` is fine here, because we converted the integer+    -- in the opposite direction first, so it fits even in 31 bit `Int`++-- Note that @Ord@ on @Int@ is not monotonic wrt @Ord@ on @Point@.+-- We need to keep it that way, because we want close xs to have close indexes,+-- e.g., adjacent points in line to have adjacent enumerations,+-- because some of the screen layout and most of processing is line-by-line.+-- Consequently, one can use EM.fromDistinctAscList+-- on @(1, 8)..(10, 8)@, but not on @(1, 7)..(10, 9)@.+instance Enum Point where+  fromEnum Point{..} =+    let !xsize = PA.indexPrimArray speedupHackXSize 0+    in+#ifdef WITH_EXPENSIVE_ASSERTIONS+       assert (px >= 0 && py >= 0 && px < xsize+              `blame` "invalid point coordinates"+              `swith` (px, py))+#endif+         (px + py * xsize)+  toEnum n = let !xsize = PA.indexPrimArray speedupHackXSize 0+                 (py, px) = n `quotRem` xsize+             in Point{..}++instance Arbitrary Point where+  arbitrary = do+    let xsize = PA.indexPrimArray speedupHackXSize 0+    n <- getSize+    Point <$> choose (0, min n (xsize - 1))+          <*> choose (0, n)++-- | Enumeration representation of @Point@.+type PointI = Int++-- This is hidden from Haddock, but run by doctest:+-- $+-- prop> (toEnum :: PointI -> Point) (fromEnum p) == p+-- prop> \ (NonNegative i) -> (fromEnum :: Point -> PointI) (toEnum i) == i++-- | The distance between two points in the chessboard metric.+--+-- >>> chessDist (Point 0 0) (Point 0 0)+-- 0+-- >>> chessDist (Point (-1) 0) (Point 0 0)+-- 1+-- >>> chessDist (Point (-1) 0) (Point (-1) 1)+-- 1+-- >>> chessDist (Point (-1) 0) (Point 0 1)+-- 1+-- >>> chessDist (Point (-1) 0) (Point 1 1)+-- 2+--+-- prop> chessDist p1 p2 >= 0+-- prop> chessDist p1 p2 ^ (2 :: Int) <= euclidDistSq p1 p2+chessDist :: Point -> Point -> Int+chessDist (Point x0 y0) (Point x1 y1) = max (abs (x1 - x0)) (abs (y1 - y0))++-- | Squared euclidean distance between two points.+euclidDistSq :: Point -> Point -> Int+euclidDistSq (Point x0 y0) (Point x1 y1) =+  (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int)++-- | Checks whether two points are adjacent on the map+-- (horizontally, vertically or diagonally).+adjacent :: Point -> Point -> Bool+{-# INLINE adjacent #-}+adjacent s t = chessDist s t == 1++-- | Bresenham's line algorithm generalized to arbitrary starting @eps@+-- (@eps@ value of 0 gives the standard BLA).+-- Skips the source point and goes through the second point to infinity.+-- Gives @Nothing@ if the points are equal. The target is given as @Point@,+-- not @PointI@, to permit aiming out of the level, e.g., to get+-- uniform distributions of directions for explosions close to the edge+-- of the level.+--+-- >>> bresenhamsLineAlgorithm 0 (Point 0 0) (Point 0 0)+-- Nothing+-- >>> take 3 $ fromJust $ bresenhamsLineAlgorithm 0 (Point 0 0) (Point 1 0)+-- [(1,0),(2,0),(3,0)]+-- >>> take 3 $ fromJust $ bresenhamsLineAlgorithm 0 (Point 0 0) (Point 0 1)+-- [(0,1),(0,2),(0,3)]+-- >>> take 3 $ fromJust $ bresenhamsLineAlgorithm 0 (Point 0 0) (Point 1 1)+-- [(1,1),(2,2),(3,3)]+bresenhamsLineAlgorithm :: Int -> Point -> Point -> Maybe [Point]+bresenhamsLineAlgorithm eps source target =+  if source == target then Nothing+  else Just $ tail $ bresenhamsLineAlgorithmBegin eps source target++-- | Bresenham's line algorithm generalized to arbitrary starting @eps@+-- (@eps@ value of 0 gives the standard BLA). Includes the source point+-- and goes through the target point to infinity.+--+-- >>> take 4 $ bresenhamsLineAlgorithmBegin 0 (Point 0 0) (Point 2 0)+-- [(0,0),(1,0),(2,0),(3,0)]+bresenhamsLineAlgorithmBegin :: Int -> Point -> Point -> [Point]+bresenhamsLineAlgorithmBegin eps (Point x0 y0) (Point x1 y1) =+  let (dx, dy) = (x1 - x0, y1 - y0)+      xyStep b (x, y) = (x + signum dx,     y + signum dy * b)+      yxStep b (x, y) = (x + signum dx * b, y + signum dy)+      (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep)+                   | otherwise       = (abs dx, abs dy, yxStep)+      bw = balancedWord p q (eps `mod` max 1 q)+      walk w xy = xy : walk (tail w) (step (head w) xy)+  in map (uncurry Point) $ walk bw (x0, y0)++-- | See <http://roguebasin.roguelikedevelopment.org/index.php/index.php?title=Digital_lines>.+balancedWord :: Int -> Int -> Int -> [Int]+balancedWord p q eps | eps + p < q = 0 : balancedWord p q (eps + p)+balancedWord p q eps               = 1 : balancedWord p q (eps + p - q)++-- | A list of all points on a straight vertical or straight horizontal line+-- between two points. Fails if no such line exists.+--+-- >>> fromTo (Point 0 0) (Point 2 0)+-- [(0,0),(1,0),(2,0)]+fromTo :: Point -> Point -> [Point]+fromTo (Point x0 y0) (Point x1 y1) =+ let fromTo1 :: Int -> Int -> [Int]+     fromTo1 z0 z1+       | z0 <= z1  = [z0..z1]+       | otherwise = [z0,z0-1..z1]+     result+       | x0 == x1 = map (Point x0) (fromTo1 y0 y1)+       | y0 == y1 = map (`Point` y0) (fromTo1 x0 x1)+       | otherwise = error $ "diagonal fromTo"+                             `showFailure` ((x0, y0), (x1, y1))+ in result++originPoint :: Point+originPoint = Point 0 0++-- | Checks that a point belongs to an area.+insideP :: (X, Y, X, Y) -> Point -> Bool+{-# INLINE insideP #-}+insideP (x0, y0, x1, y1) (Point x y) = x1 >= x && x >= x0 && y1 >= y && y >= y0
+ engine-src/Game/LambdaHack/Common/PointArray.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE FlexibleContexts, StandaloneDeriving, TypeFamilies #-}+-- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@.+module Game.LambdaHack.Common.PointArray+  ( UnboxRepClass(..), Array(..)+  , empty, (!), accessI, (//), replicateA, unfoldrNA+  , foldrA, foldrA', foldlA', ifoldlA', ifoldrA', foldMA'+  , mapA, imapA, imapMA_, minIndexesA, maxIndexA, maxIndexByA, maxLastIndexA+  , toListA+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , toUnboxRep+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import           Data.Vector.Binary ()+import qualified Data.Vector.Fusion.Bundle as Bundle+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U++import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs+import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal++class ( Ord c, Eq (UnboxRep c), Ord (UnboxRep c), Bounded (UnboxRep c)+      , Binary (UnboxRep c), U.Unbox (UnboxRep c) )+      => UnboxRepClass c where+  type UnboxRep c+  type instance UnboxRep c = c+  toUnboxRepUnsafe :: c -> UnboxRep c  -- has to be total+  fromUnboxRep :: UnboxRep c -> c  -- has to be total++instance UnboxRepClass Bool where+  toUnboxRepUnsafe c = c+  fromUnboxRep c = c++instance UnboxRepClass Word8 where+  toUnboxRepUnsafe c = c+  fromUnboxRep c = c++instance UnboxRepClass (ContentId k) where+  type UnboxRep (ContentId k) = Word16+  toUnboxRepUnsafe = DefsInternal.fromContentId+  fromUnboxRep = DefsInternal.toContentId++instance UnboxRepClass Color.AttrCharW32 where+  type UnboxRep Color.AttrCharW32 = Word32+  toUnboxRepUnsafe = Color.attrCharW32+  fromUnboxRep = Color.AttrCharW32++-- | Arrays indexed by @Point@.+data Array c = Array+  { axsize  :: X+  , aysize  :: Y+  , avector :: U.Vector (UnboxRep c)+  }++deriving instance UnboxRepClass c => Eq (Array c)++instance Show (Array c) where+  show a = "PointArray.Array with size " ++ show (axsize a, aysize a)++instance UnboxRepClass c => Binary (Array c) where+  put Array{..} = do+    put axsize+    put aysize+    put avector+  get = do+    axsize <- get+    aysize <- get+    avector <- get+    return $! Array{..}++toUnboxRep :: UnboxRepClass c => c -> UnboxRep c+{-# INLINE toUnboxRep #-}+toUnboxRep c =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  assert (c <= fromUnboxRep maxBound) $+#endif+    toUnboxRepUnsafe c++empty :: UnboxRepClass c => Array c+empty = Array 0 0 U.empty++-- Note: there's no point specializing this to @Point@ arguments,+-- since the extra few additions in @fromPoint@ may be less expensive than+-- memory or register allocations needed for the extra @Int@ in @Point@.+-- | Array lookup.+(!) :: UnboxRepClass c => Array c -> Point -> c+{-# INLINE (!) #-}+(!) Array{..} p = fromUnboxRep $ avector U.! fromEnum p++accessI :: UnboxRepClass c => Array c -> Int -> UnboxRep c+{-# INLINE accessI #-}+accessI Array{..} p = avector `vectorUnboxedUnsafeIndex` p++-- | Construct an array updated with the association list.+(//) :: UnboxRepClass c => Array c -> [(Point, c)] -> Array c+{-# INLINE (//) #-}+(//) Array{..} l = let v = avector U.// map (fromEnum *** toUnboxRep) l+                   in Array{avector = v, ..}++-- unsafeUpdateA :: UnboxRepClass c => Array c -> [(Point, c)] -> ()+-- {-# INLINE unsafeUpdateA #-}+-- unsafeUpdateA Array{..} l = runST $ do+--   vThawed <- U.unsafeThaw avector+--   mapM_ (\(p, c) -> VM.write vThawed (fromEnum p) (toUnboxRep c)) l+--   void $ U.unsafeFreeze vThawed++-- unsafeWriteA :: UnboxRepClass c => Array c -> Point -> c -> ()+-- {-# INLINE unsafeWriteA #-}+-- unsafeWriteA Array{..} p c = runST $ do+--   vThawed <- U.unsafeThaw avector+--   VM.write vThawed (fromEnum p) (toUnboxRep c)+--   void $ U.unsafeFreeze vThawed++-- unsafeWriteManyA :: UnboxRepClass c => Array c -> [Point] -> c -> ()+-- {-# INLINE unsafeWriteManyA #-}+-- unsafeWriteManyA Array{..} l c = runST $ do+--   vThawed <- U.unsafeThaw avector+--   let d = toUnboxRep c+--   mapM_ (\p -> VM.write vThawed (fromEnum p) d) l+--   void $ U.unsafeFreeze vThawed++-- | Create an array from a replicated element.+replicateA :: UnboxRepClass c => X -> Y -> c -> Array c+{-# INLINE replicateA #-}+replicateA axsize aysize c =+  Array{avector = U.replicate (axsize * aysize) $ toUnboxRep c, ..}++-- -- | Create an array from a replicated monadic action.+-- replicateMA :: (Monad m, UnboxRepClass c) => X -> Y -> m c -> m (Array c)+-- {-# INLINE replicateMA #-}+-- replicateMA axsize aysize m = do+--   v <- U.replicateM (axsize * aysize) $ liftM toUnboxRep m+--   return $! Array{avector = v, ..}++-- -- | Create an array from a function.+-- generateA :: UnboxRepClass c => X -> Y -> (Point -> c) -> Array c+-- {-# INLINE generateA #-}+-- generateA axsize aysize f =+--   let g n = toUnboxRep $ f $ toEnum n+--   in Array{avector = U.generate (axsize * aysize) g, ..}++-- -- | Create an array from a monadic function.+-- generateMA :: (Monad m, UnboxRepClass c)+--            => X -> Y -> (Point -> m c) -> m (Array c)+-- {-# INLINE generateMA #-}+-- generateMA axsize aysize fm = do+--   let gm n = liftM toUnboxRep $ fm $ toEnum n+--   v <- U.generateM (axsize * aysize) gm+--   return $! Array{avector = v, ..}++unfoldrNA :: UnboxRepClass c => X -> Y -> (b -> (c, b)) -> b -> Array c+{-# INLINE unfoldrNA #-}+unfoldrNA axsize aysize fm b =+  let gm = Just . first toUnboxRep . fm+      v = U.unfoldrN (axsize * aysize) gm b+  in Array {avector = v, ..}++-- -- | Content identifiers array size.+-- sizeA :: Array c -> (X, Y)+-- {-# INLINE sizeA #-}+-- sizeA Array{..} = (axsize, aysize)++-- | Fold right over an array.+foldrA :: UnboxRepClass c => (c -> a -> a) -> a -> Array c -> a+{-# INLINE foldrA #-}+foldrA f z0 Array{..} = U.foldr (f . fromUnboxRep) z0 avector++-- | Fold right strictly over an array.+foldrA' :: UnboxRepClass c => (c -> a -> a) -> a -> Array c -> a+{-# INLINE foldrA' #-}+foldrA' f z0 Array{..} = U.foldr' (f . fromUnboxRep) z0 avector++-- | Fold left strictly over an array.+foldlA' :: UnboxRepClass c => (a -> c -> a) -> a -> Array c -> a+{-# INLINE foldlA' #-}+foldlA' f z0 Array{..} =+  U.foldl' (\a c -> f a (fromUnboxRep c)) z0 avector++-- | Fold left strictly over an array+-- (function applied to each element and its index).+ifoldlA' :: UnboxRepClass c => (a -> Point -> c -> a) -> a -> Array c -> a+{-# INLINE ifoldlA' #-}+ifoldlA' f z0 Array{..} =+  U.ifoldl' (\a n c -> f a (toEnum n) (fromUnboxRep c)) z0 avector++-- -- | Fold right over an array+-- -- (function applied to each element and its index).+-- ifoldrA :: UnboxRepClass c => (Point -> c -> a -> a) -> a -> Array c -> a+-- {-# INLINE ifoldrA #-}+-- ifoldrA f z0 Array{..} =+--   U.ifoldr (\n c a -> f (toEnum n) (fromUnboxRep c) a) z0 avector++-- | Fold right strictly over an array+-- (function applied to each element and its index).+ifoldrA' :: UnboxRepClass c => (Point -> c -> a -> a) -> a -> Array c -> a+{-# INLINE ifoldrA' #-}+ifoldrA' f z0 Array{..} =+  U.ifoldr' (\n c a -> f (toEnum n) (fromUnboxRep c) a) z0 avector++-- | Fold monadically strictly over an array.+foldMA' :: (Monad m, UnboxRepClass c) => (a -> c -> m a) -> a -> Array c -> m a+{-# INLINE foldMA' #-}+foldMA' f z0 Array{..} =+  U.foldM' (\a c -> f a (fromUnboxRep c)) z0 avector++-- -- | Fold monadically strictly over an array+-- -- (function applied to each element and its index).+-- ifoldMA' :: (Monad m, UnboxRepClass c)+--          => (a -> Point -> c -> m a) -> a -> Array c -> m a+-- {-# INLINE ifoldMA' #-}+-- ifoldMA' f z0 Array{..} =+--   U.ifoldM' (\a n c -> f a (toEnum n) (fromUnboxRep c)) z0 avector++-- | Map over an array.+mapA :: (UnboxRepClass c, UnboxRepClass d) => (c -> d) -> Array c -> Array d+{-# INLINE mapA #-}+mapA f Array{..} =+  Array{avector = U.map (toUnboxRep . f . fromUnboxRep) avector, ..}++-- | Map over an array (function applied to each element and its index).+imapA :: (UnboxRepClass c, UnboxRepClass d)+      =>  (Point -> c -> d) -> Array c -> Array d+{-# INLINE imapA #-}+imapA f Array{..} =+  let v = U.imap (\n c ->+                   toUnboxRep $ f (toEnum n) (fromUnboxRep c)) avector+  in Array{avector = v, ..}++-- | Map monadically over an array (function applied to each element+-- and its index) and ignore the results.+imapMA_ :: (Monad m, UnboxRepClass c) => (Point -> c -> m ()) -> Array c -> m ()+{-# INLINE imapMA_ #-}+imapMA_ f Array{..} =+  U.imapM_ (\n c -> f (toEnum n) (fromUnboxRep c)) avector++-- -- | Set all elements to the given value, in place.+-- unsafeSetA :: UnboxRepClass c => c -> Array c -> Array c+-- {-# INLINE unsafeSetA #-}+-- unsafeSetA c Array{..} = runST $ do+--   vThawed <- U.unsafeThaw avector+--   VM.set vThawed (toUnboxRep c)+--   vFrozen <- U.unsafeFreeze vThawed+--   return $! Array{avector = vFrozen, ..}++-- -- | Set all elements to the given value, in place, if possible.+-- safeSetA :: UnboxRepClass c => c -> Array c -> Array c+-- {-# INLINE safeSetA #-}+-- safeSetA c Array{..} =+--   Array{avector = U.modify (\v -> VM.set v (toUnboxRep c)) avector, ..}++-- -- | Yield the point coordinates of a minimum element of the array.+-- -- The array may not be empty.+-- minIndexA :: UnboxRepClass c => Array c -> Point+-- {-# INLINE minIndexA #-}+-- minIndexA Array{..} = toEnum $ U.minIndex avector++-- -- | Yield the point coordinates of the last minimum element of the array.+-- -- The array may not be empty.+-- minLastIndexA :: UnboxRepClass c => Array c -> Point+-- {-# INLINE minLastIndexA #-}+-- minLastIndexA Array{..} =+--   toEnum+--   $ fst . Bundle.foldl1' imin . Bundle.indexed . G.stream+--   $ avector+--  where+--   imin (i, x) (j, y) = i `seq` j `seq` if x >= y then (j, y) else (i, x)++-- | Yield the point coordinates of all the minimum elements of the array.+-- The array may not be empty.+minIndexesA :: UnboxRepClass c => Array c -> [Point]+{-# INLINE minIndexesA #-}+minIndexesA Array{..} =+  Bundle.foldr imin [] . Bundle.indexed . G.stream $ avector+ where+  imin (i, x) acc = if x == minE+                    then let !j = toEnum i+                         in j : acc+                    else acc+  !minE = U.minimum avector++-- | Yield the point coordinates of the first maximum element of the array.+-- The array may not be empty.+maxIndexA :: UnboxRepClass c => Array c -> Point+{-# INLINE maxIndexA #-}+maxIndexA Array{..} = toEnum $ U.maxIndex avector++-- | Yield the point coordinates of the first maximum element of the array.+-- The array may not be empty.+maxIndexByA :: UnboxRepClass c => (c -> c -> Ordering) -> Array c -> Point+{-# INLINE maxIndexByA #-}+maxIndexByA f Array{..} =+  let g a b = f (fromUnboxRep a) (fromUnboxRep b)+  in toEnum $ U.maxIndexBy g avector++-- | Yield the point coordinates of the last maximum element of the array.+-- The array may not be empty.+maxLastIndexA :: UnboxRepClass c => Array c -> Point+{-# INLINE maxLastIndexA #-}+maxLastIndexA Array{..} =+  toEnum+  $ fst . Bundle.foldl1' imax . Bundle.indexed . G.stream+  $ avector+ where+  imax (i, x) (j, y) = i `seq` j `seq` if x <= y then (j, y) else (i, x)++-- -- | Force the array not to retain any extra memory.+-- forceA :: UnboxRepClass c => Array c -> Array c+-- {-# INLINE forceA #-}+-- forceA Array{..} = Array{avector = U.force avector, ..}++-- fromListA :: UnboxRepClass c => X -> Y -> [c] -> Array c+-- {-# INLINE fromListA #-}+-- fromListA axsize aysize l =+--   Array{avector = U.fromListN (axsize * aysize) $ map toUnboxRep l, ..}++toListA :: UnboxRepClass c => Array c -> [c]+{-# INLINE toListA #-}+toListA Array{..} = map fromUnboxRep $ U.toList avector
+ engine-src/Game/LambdaHack/Common/ReqFailure.hs view
@@ -0,0 +1,252 @@+-- | Possible causes of failure of request.+module Game.LambdaHack.Common.ReqFailure+  ( ReqFailure(..)+  , impossibleReqFailure, showReqFailure+  , permittedPrecious, permittedProject, permittedProjectAI, permittedApply+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Time+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.RuleKind as RK+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | Possible causes of failure of request.+data ReqFailure =+    MoveUnskilled+  | MoveUnskilledAsleep+  | MoveNothing+  | MeleeUnskilled+  | MeleeSelf+  | MeleeDistant+  | MeleeNotWeapon+  | DisplaceUnskilled+  | DisplaceDistant+  | DisplaceAccess+  | DisplaceMultiple+  | DisplaceDying+  | DisplaceBraced+  | DisplaceImmobile+  | DisplaceSupported+  | AlterUnskilled+  | AlterUnwalked+  | AlterDistant+  | AlterBlockActor+  | AlterBlockItem+  | AlterNothing+  | CloseDistant+  | CloseClosed+  | CloseNothing+  | CloseNonClosable+  | WaitUnskilled+  | YellUnskilled+  | MoveItemUnskilled+  | EqpOverfull+  | EqpStackFull+  | ApplyUnskilled+  | ApplyFood+  | ApplyRead+  | ApplyPeriodic+  | ApplyOutOfReach+  | ApplyCharging+  | ApplyNoEffects+  | ItemNothing+  | ItemNotCalm+  | ItemOverStash+  | NotCalmPrecious+  | ProjectUnskilled+  | ProjectAimOnself+  | ProjectBlockTerrain+  | ProjectBlockActor+  | ProjectLobable+  | ProjectOutOfReach+  | ProjectFinderKeeper+  | NoChangeDunLeader+  deriving (Show, Eq)++impossibleReqFailure :: ReqFailure -> Bool+impossibleReqFailure reqFailure = case reqFailure of+  MoveUnskilled -> False  -- unidentified skill items+  MoveUnskilledAsleep -> False  -- unidentified skill items+  MoveNothing -> True+  MeleeUnskilled -> False  -- unidentified skill items+  MeleeSelf -> True+  MeleeDistant -> True+  MeleeNotWeapon -> False  -- unidentified items+  DisplaceUnskilled -> False  -- unidentified skill items+  DisplaceDistant -> True+  DisplaceAccess -> True+  DisplaceMultiple -> True+  DisplaceDying -> True+  DisplaceBraced -> True+  DisplaceImmobile -> False  -- unidentified skill items+  DisplaceSupported -> False+  AlterUnskilled -> False  -- unidentified skill items+  AlterUnwalked -> False+  AlterDistant -> True+  AlterBlockActor -> True  -- adjacent actor always visible+  AlterBlockItem -> True  -- adjacent item always visible+  AlterNothing -> True  -- if tile known, its properties known+  CloseDistant -> True+  CloseClosed -> True+  CloseNothing -> True+  CloseNonClosable -> True+  WaitUnskilled -> False  -- unidentified skill items+  YellUnskilled -> False  -- unidentified skill items+  MoveItemUnskilled -> False  -- unidentified skill items+  EqpOverfull -> True+  EqpStackFull -> True+  ApplyUnskilled -> False  -- unidentified skill items+  ApplyFood -> False  -- unidentified skill items+  ApplyRead -> False  -- unidentified skill items+  ApplyPeriodic -> False  -- unidentified skill items+  ApplyOutOfReach -> True+  ApplyCharging -> False  -- if aspect record unknown, charging unknown+  ApplyNoEffects -> False  -- if effects unknown, can't prevent it+  ItemNothing -> True+  ItemNotCalm -> False  -- unidentified skill items+  ItemOverStash -> True+  NotCalmPrecious -> False  -- unidentified skill items+  ProjectUnskilled -> False  -- unidentified skill items+  ProjectAimOnself -> True+  ProjectBlockTerrain -> True  -- adjacent terrain always visible+  ProjectBlockActor -> True  -- adjacent actor always visible+  ProjectLobable -> False  -- unidentified skill items+  ProjectOutOfReach -> True+  ProjectFinderKeeper -> False+  NoChangeDunLeader -> True++showReqFailure :: ReqFailure -> Text+showReqFailure reqFailure = case reqFailure of+  MoveUnskilled -> "too low movement stat; use equipment menu to take off stat draining gear or switch to another teammate or wait until a stat draining condition passes as seen in organ menu"+  MoveUnskilledAsleep -> "actor asleep; yawn to wake up"+  MoveNothing -> "wasting time on moving into obstacle"+  MeleeUnskilled -> "too low melee combat stat"+  MeleeSelf -> "trying to melee oneself"+  MeleeDistant -> "trying to melee a distant foe"+  MeleeNotWeapon -> "trying to melee with not a weapon"+  DisplaceUnskilled -> "too low actor displacing stat"+  DisplaceDistant -> "trying to displace a distant actor"+  DisplaceAccess -> "trying to switch places without access"+  DisplaceMultiple -> "trying to displace multiple actors"+  DisplaceDying -> "trying to displace a dying foe"+  DisplaceBraced -> "trying to displace a braced foe"+  DisplaceImmobile -> "trying to displace an immobile foe"+  DisplaceSupported -> "trying to displace a foe supported by teammates or supply stash"+  AlterUnskilled -> "modify stat is needed to search or activate or transform terrain"+  AlterUnwalked -> "too low modify stat to enter or activate or transform terrain; find and equip gear that improves the stat or try with a teammate whose skill menu shows a higher stat"+  AlterDistant -> "trying to modify distant terrain"+  AlterBlockActor -> "blocked by an actor"+  AlterBlockItem -> "jammed by an item"+  AlterNothing -> "wasting time on modifying nothing"+  CloseDistant -> "trying to close a distant terrain"+  CloseClosed -> "already closed"+  CloseNothing -> "no adjacent terrain can be closed"+  CloseNonClosable -> "cannot be closed"+  WaitUnskilled -> "too low wait stat"+  YellUnskilled -> "actors unskilled in waiting cannot yell/yawn"+  MoveItemUnskilled -> "too low item moving stat"+  EqpOverfull -> "cannot equip any more items"+  EqpStackFull -> "cannot equip the whole item stack"+  ApplyUnskilled -> "too low item triggering stat"+  ApplyFood -> "trigger stat 1 is enough only to eat food from the ground and trigger simple appendages"+  ApplyRead -> "activating cultural artifacts requires trigger stat 3"+  ApplyPeriodic -> "manually activating periodic items requires trigger stat 4"+  ApplyOutOfReach -> "cannot trigger an item out of reach"+  ApplyCharging -> "cannot trigger an item that is still charging"+  ApplyNoEffects -> "cannot trigger an item that produces no effect"+  ItemNothing -> "wasting time on void item manipulation"+  ItemNotCalm -> "you try to focus on your equipment but your calm fails you"+  ItemOverStash -> "you roll in your hoard a little"+  NotCalmPrecious -> "you are too distracted to handle such an exquisite item"+  ProjectUnskilled -> "too low item flinging stat"+  ProjectAimOnself -> "cannot aim at oneself"+  ProjectBlockTerrain -> "aiming obstructed by terrain"+  ProjectBlockActor -> "aiming blocked by an actor"+  ProjectLobable -> "flinging a lobable item that stops at target position requires fling stat 3"+  ProjectOutOfReach -> "cannot aim an item out of reach"+  ProjectFinderKeeper -> "flinging any projectile you've found is out of the question; you prefer to keep them pristine and safe"+  NoChangeDunLeader -> "no manual level change for your team"++-- The item should not be applied nor thrown because it's too delicate+-- to operate when not calm or because it's too precious to identify by use.+permittedPrecious :: Bool -> Bool -> ItemFull -> Either ReqFailure Bool+permittedPrecious forced calmE itemFull@ItemFull{itemDisco} =+  let arItem = aspectRecordFull itemFull+      isPrecious = IA.checkFlag Ability.Precious arItem+  in if not forced && not calmE && isPrecious+     then Left NotCalmPrecious+     else Right $ IA.checkFlag Ability.Durable arItem+                  || case itemDisco of+                       ItemDiscoFull{} -> True+                       ItemDiscoMean itemAspectMean ->+                         IA.kmConst itemAspectMean || not isPrecious++-- Simplified, faster version, for inner AI loop.+permittedPreciousAI :: Bool -> ItemFull -> Bool+permittedPreciousAI calmE itemFull@ItemFull{itemDisco} =+  let arItem = aspectRecordFull itemFull+      isPrecious = IA.checkFlag Ability.Precious arItem+  in (calmE || not isPrecious)+     && IA.checkFlag Ability.Durable arItem+        || case itemDisco of+             ItemDiscoFull{} -> True+             ItemDiscoMean itemAspectMean ->+               IA.kmConst itemAspectMean || not isPrecious++permittedProject :: Bool -> Int -> Bool -> ItemFull -> Either ReqFailure Bool+permittedProject forced skill calmE itemFull =+ let arItem = aspectRecordFull itemFull+ in if | not forced && skill < 1 -> Left ProjectUnskilled+       | not forced+         && IA.checkFlag Ability.Lobable arItem+         && skill < 3 -> Left ProjectLobable+       | otherwise -> permittedPrecious forced calmE itemFull++-- Simplified, faster and more permissive version, for inner AI loop.+permittedProjectAI :: Int -> Bool -> ItemFull -> Bool+permittedProjectAI skill calmE itemFull =+ let arItem = aspectRecordFull itemFull+ in if | skill < 1 -> False+       | IA.checkFlag Ability.Lobable arItem+         && skill < 3 -> False+       | otherwise -> permittedPreciousAI calmE itemFull++permittedApply :: RK.RuleContent -> Time -> Int -> Bool -> Maybe CStore+               -> ItemFull -> ItemQuant+               -> Either ReqFailure Bool+permittedApply corule localTime skill calmE mstore+               itemFull@ItemFull{itemKind, itemSuspect} kit =+  if | skill < 1 -> Left ApplyUnskilled+     | skill < 2+       && IK.isymbol itemKind /= IK.rsymbolNecklace (RK.ritemSymbols corule)+       && (IK.isymbol itemKind /= IK.rsymbolFood (RK.ritemSymbols corule)+           || mstore /= Just CGround) -> Left ApplyFood+     | skill < 3+       && IK.isymbol itemKind == IK.rsymbolScroll (RK.ritemSymbols corule) ->+         Left ApplyRead+     | skill < 4+       && let arItem = aspectRecordFull itemFull+          in IA.checkFlag Ability.Periodic arItem -> Left ApplyPeriodic+     -- If the item is discharged, neither the kinetic hit nor+     -- any effects activate, so there's no point triggering.+     -- Note that if client doesn't know the timeout, here we may leak the fact+     -- that the item is still charging, but the client risks destruction+     -- if the item is, in fact, recharged and is not durable+     -- (likely in case of jewellery). So it's OK (the message may be+     -- somewhat alarming though).+     | not $ hasCharge localTime kit -> Left ApplyCharging+     | otherwise ->+       if null (IK.ieffects itemKind)+          && (not itemSuspect || IA.isHumanTrinket itemKind)+       then Left ApplyNoEffects+       else permittedPrecious False calmE itemFull
+ engine-src/Game/LambdaHack/Common/RingBuffer.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Ring buffers.+module Game.LambdaHack.Common.RingBuffer+  ( RingBuffer+  , empty, cons, toList, length+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude hiding (length, uncons)++import           Data.Binary+import qualified Data.Foldable as Foldable+import qualified Data.Sequence as Seq+import           GHC.Generics (Generic)++-- | Ring buffers of a size determined at initialization.+data RingBuffer a = RingBuffer+  { rbCarrier :: Seq.Seq a+  , rbMaxSize :: Int+  , rbNext    :: Int+  , rbLength  :: Int+  }+  deriving (Show, Generic)++instance Binary a => Binary (RingBuffer a)++-- Only takes O(log n)).+empty :: Int -> a -> RingBuffer a+empty size dummy =+  let rbMaxSize = max 1 size+  in RingBuffer (Seq.replicate rbMaxSize dummy) rbMaxSize 0 0++cons :: a -> RingBuffer a -> RingBuffer a+cons a RingBuffer{..} =+  let incNext = (rbNext + 1) `mod` rbMaxSize+      incLength = min rbMaxSize $ rbLength + 1+  in RingBuffer (Seq.update rbNext a rbCarrier) rbMaxSize incNext incLength++toList :: RingBuffer a -> [a]+toList RingBuffer{..} =+  let l = Foldable.toList rbCarrier+      start = (rbNext + rbMaxSize - rbLength) `mod` rbMaxSize+  in take rbLength $ drop start $ l ++ l++length :: RingBuffer a -> Int+length RingBuffer{rbLength} = rbLength
+ engine-src/Game/LambdaHack/Common/Save.hs view
@@ -0,0 +1,186 @@+-- | Saving and restoring game state, used by both server and clients.+module Game.LambdaHack.Common.Save+  ( ChanSave, saveToChan, wrapInSaves, restoreGame+  , compatibleVersion, delayPrint+  , saveNameCli, saveNameSer, bkpAllSaves+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , loopSave+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import           Control.Concurrent.Async+import qualified Control.Exception as Ex+import           Data.Binary+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Data.Version+import           System.FilePath+import           System.IO (hFlush, stdout)+import qualified System.Random.SplitMix32 as SM++import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.File+import Game.LambdaHack.Common.Kind+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Types+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Core.Random++type ChanSave a = MVar (Maybe a)++saveToChan :: ChanSave a -> a -> IO ()+saveToChan toSave s = do+  -- Wipe out previous candidates for saving.+  void $ tryTakeMVar toSave+  putMVar toSave $ Just s++-- | Repeatedly save serialized snapshots of current state.+--+-- Running with @-N2@ ca reduce @Max pause@ from 0.2s to 0.01s+-- and @bytes copied during GC@ 10-fold, but framerate nor the frequency+-- of not making a backup save are unaffected (at standard backup settings),+-- even with null frontend, because saving takes so few resources.+-- So, generally, backup save settings are relevant only due to latency+-- impact on very slow computers or in JS.+loopSave :: Binary a => COps -> (a -> FilePath) -> ChanSave a -> IO ()+loopSave cops stateToFileName toSave =+  loop+ where+  loop = do+    -- Wait until anyting to save.+    ms <- takeMVar toSave+    case ms of+      Just s -> do+        dataDir <- appDataDir+        tryCreateDir (dataDir </> "saves")+        let fileName = stateToFileName s+        yield  -- minimize UI lag due to saving+        encodeEOF (dataDir </> "saves" </> fileName)+                  (rexeVersion $ corule cops)+                  s+        -- Wait until the save finished. During that time, the mvar+        -- is continually updated to newest state values.+        loop+      Nothing -> return ()  -- exit++wrapInSaves :: Binary a+            => COps -> (a -> FilePath) -> (ChanSave a -> IO ()) -> IO ()+{-# INLINE wrapInSaves #-}+wrapInSaves cops stateToFileName exe = do+  -- We don't merge this with the other calls to waitForChildren,+  -- because, e.g., for server, we don't want to wait for clients to exit,+  -- if the server crashes (but we wait for the save to finish).+  toSave <- newEmptyMVar+  a <- async $ loopSave cops stateToFileName toSave+  link a+  let fin = do+        -- Wait until the last save (if any) starts+        -- and tell the save thread to end.+        putMVar toSave Nothing+        -- Wait 0.5s to flush debug and then until the save thread ends.+        threadDelay 500000+        wait a+  exe toSave `Ex.finally` fin+  -- The creation of, e.g., the initial client state, is outside the 'finally'+  -- clause, but this is OK, since no saves are ordered until 'runActionCli'.+  -- We save often, not only in the 'finally' section, in case of+  -- power outages, kill -9, GHC runtime crashes, etc. For internal game+  -- crashes, C-c, etc., the finalizer would be enough.+  -- If we implement incremental saves, saving often will help+  -- to spread the cost, to avoid a long pause at game exit.++-- | Restore a saved game, if it exists. Initialize directory structure+-- and copy over data files, if needed.+restoreGame :: Binary a+            => RuleContent -> ClientOptions -> FilePath -> IO (Maybe a)+restoreGame corule clientOptions fileName = do+  -- Create user data directory and copy files, if not already there.+  dataDir <- appDataDir+  tryCreateDir dataDir+  let path = dataDir </> "saves" </> fileName+  saveExists <- doesFileExist path+  -- If the savefile exists but we get IO or decoding errors,+  -- we show them and start a new game. If the savefile was randomly+  -- corrupted or made read-only, that should solve the problem.+  -- OTOH, serious IO problems (e.g. failure to create a user data directory)+  -- terminate the program with an exception.+  res <- Ex.try $+    if saveExists then do+      let vExe1 = rexeVersion corule+      (vExe2, s) <- strictDecodeEOF path+      if compatibleVersion vExe1 vExe2+      then return $! s `seq` Just s+      else do+        let msg = "Savefile" <+> T.pack path+                  <+> "from an incompatible version"+                  <+> T.pack (showVersion vExe2)+                  <+> "detected while trying to restore"+                  <+> T.pack (showVersion vExe1)+                  <+> "game."+        fail $ T.unpack msg+    else return Nothing+  let handler :: Ex.SomeException -> IO (Maybe a)+      handler e = do+        moveAside <- bkpAllSaves corule clientOptions+        let msg = "Restore failed."+                  <+> (if moveAside+                      then "The wrong file has been moved aside."+                      else "")+                  <+> "The error message is:"+                  <+> (T.unwords . T.lines) (tshow e)+        delayPrint msg+        return Nothing+  either handler return res++-- Minor version discrepancy permitted.+compatibleVersion :: Version -> Version -> Bool+compatibleVersion v1 v2 = take 3 (versionBranch v1) == take 3 (versionBranch v2)++delayPrint :: Text -> IO ()+delayPrint t = do+  smgen <- SM.newSMGen+  let (delay, _) = nextRandom 10000 smgen+  threadDelay $ 100 * delay  -- try not to interleave saves with other clients+  T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough+  hFlush stdout++saveNameCli :: RuleContent -> FactionId -> String+saveNameCli corule side =+  let gameShortName =+        case words $ rtitle corule of+          w : _ -> w+          _ -> "Game"+  in gameShortName+     ++ ".team_" ++ show (fromEnum side)+     ++ ".sav"++saveNameSer :: RuleContent -> String+saveNameSer corule =+  let gameShortName =+        case words $ rtitle corule of+          w : _ -> w+          _ -> "Game"+  in gameShortName ++ ".server.sav"++bkpAllSaves :: RuleContent -> ClientOptions -> IO Bool+bkpAllSaves corule clientOptions = do+  dataDir <- appDataDir+  let benchmark = sbenchmark clientOptions+      defPrefix = ssavePrefixCli defClientOptions+      moveAside = not benchmark && ssavePrefixCli clientOptions == defPrefix+      bkpOneSave name = do+        let pathSave bkp = dataDir </> "saves" </> bkp <> defPrefix <> name+        b <- doesFileExist (pathSave "")+        when b $ renameFile (pathSave "") (pathSave "bkp.")+      bkpAll = do+        bkpOneSave $ saveNameSer corule+        forM_ [-199..199] $ \n ->+          bkpOneSave $ saveNameCli corule (toEnum n)+  when moveAside bkpAll+  return moveAside
+ engine-src/Game/LambdaHack/Common/State.hs view
@@ -0,0 +1,324 @@+-- | The common, for server and clients, main game state type+-- and its operations.+module Game.LambdaHack.Common.State+  ( -- * Basic game state, local or global+    State+    -- * State components+  , sdungeon, stotalDepth, sactorD, sitemD, sitemIxMap, sfactionD, stime, scops+  , sgold, shigh, sgameModeId, sdiscoKind, sdiscoAspect, sactorMaxSkills+    -- * State construction+  , defStateGlobal, emptyState, localFromGlobal+    -- * State update+  , updateDungeon, updateDepth, updateActorD, updateItemD, updateItemIxMap+  , updateFactionD, updateTime, updateCOpsAndCachedData, updateGold+  , updateDiscoKind, updateDiscoAspect, updateActorMaxSkills+    -- * State operations+  , getItemBody, aspectRecordFromItem, aspectRecordFromIid+  , maxSkillsFromActor, maxSkillsInDungeon+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , unknownLevel+#endif+    -- * Operations both internal and used in unit tests+  , unknownTileMap+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.HighScore as HighScore+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.CaveKind (CaveKind)+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs++-- | The main game state, the basic one, pertaining to a single game,+-- not to a single playing session or an intersection of both.+-- This state persists between playing sessions, until the particular game ends.+-- Anything that persists between games is stored in server state,+-- client state or client UI session state.+--+-- Another differentiating property of this state is that it's kept+-- separately on the server and each of the clients (players, human or AI)+-- and separately updated, according to what each player can observe.+-- It's never updated directly, but always through atomic commands+-- ("CmdAtomic") that are filtered and interpreted differently+-- on server and on each client. Therefore, the type is a view on the+-- game state, not the real game state, except on the server that+-- alone stores the full game information.+data State = State+  { _sdungeon        :: Dungeon    -- ^ remembered dungeon+  , _stotalDepth     :: Dice.AbsDepth+                                   -- ^ absolute dungeon depth for item creation+  , _sactorD         :: ActorDict  -- ^ remembered actors in the dungeon+  , _sitemD          :: ItemDict   -- ^ remembered items in the dungeon+  , _sitemIxMap      :: ItemIxMap  -- ^ spotted items with the same kind index+                                   --   could be recomputed at resume, but small+  , _sfactionD       :: FactionDict+                                   -- ^ remembered sides still in game+  , _stime           :: Time       -- ^ global game time, for UI display only+  , _scops           :: COps       -- ^ remembered content; warning: use only+                                   --   validated content, even for testing+  , _sgold           :: Int        -- ^ total value of human trinkets in dungeon+  , _shigh           :: HighScore.ScoreDict  -- ^ high score table+  , _sgameModeId     :: ContentId ModeKind   -- ^ current game mode+  , _sdiscoKind      :: DiscoveryKind        -- ^ item kind discoveries data+  , _sdiscoAspect    :: DiscoveryAspect+                                   -- ^ item aspect data; could be recomputed+  , _sactorMaxSkills :: ActorMaxSkills+                                   -- ^ actor maximal skills; is recomputed+  }+  deriving (Show, Eq)++instance Binary State where+  put State{..} = do+    put _sdungeon+    put _stotalDepth+    put _sactorD+    put _sitemD+    put _sitemIxMap+    put _sfactionD+    put _stime+    put _sgold+    put _shigh+    put _sgameModeId+    put _sdiscoKind+    put _sdiscoAspect+  get = do+    _sdungeon <- get+    _stotalDepth <- get+    _sactorD <- get+    _sitemD <- get+    _sitemIxMap <- get+    _sfactionD <- get+    _stime <- get+    _sgold <- get+    _shigh <- get+    _sgameModeId <- get+    _sdiscoKind <- get+    _sdiscoAspect <- get+    let _scops = emptyCOps+        _sactorMaxSkills = EM.empty+    return $! State{..}++sdungeon :: State -> Dungeon+sdungeon = _sdungeon++stotalDepth :: State -> Dice.AbsDepth+stotalDepth = _stotalDepth++sactorD :: State -> ActorDict+sactorD = _sactorD++sitemD :: State -> ItemDict+sitemD = _sitemD++sitemIxMap :: State -> ItemIxMap+sitemIxMap = _sitemIxMap++sfactionD :: State -> FactionDict+sfactionD = _sfactionD++stime :: State -> Time+stime = _stime++scops :: State -> COps+scops = _scops++sgold :: State -> Int+sgold = _sgold++shigh :: State -> HighScore.ScoreDict+shigh = _shigh++sgameModeId :: State -> ContentId ModeKind+sgameModeId = _sgameModeId++sdiscoKind :: State -> DiscoveryKind+sdiscoKind = _sdiscoKind++sdiscoAspect :: State -> DiscoveryAspect+sdiscoAspect = _sdiscoAspect++sactorMaxSkills :: State -> ActorMaxSkills+sactorMaxSkills = _sactorMaxSkills++unknownLevel :: COps -> ContentId CaveKind -> Dice.AbsDepth -> Area+             -> ([Point], [Point]) -> [Point] -> Int -> Bool+             -> Level+unknownLevel COps{corule, cotile}+             lkind ldepth larea lstair lescape lexpl lnight =+  let outerId = ouniqGroup cotile TK.S_UNKNOWN_OUTER_FENCE+  in Level { lkind+           , ldepth+           , lfloor = EM.empty+           , lembed = EM.empty+           , lbig = EM.empty+           , lproj = EM.empty+           , ltile = unknownTileMap larea outerId (rWidthMax corule) (rHeightMax corule)+           , lentry = EM.empty+           , larea+           , lsmell = EM.empty+           , lstair+           , lescape+           , lseen = 0+           , lexpl+           , ltime = timeZero+           , lnight+           }++-- | Create a map full of unknown tiles.+--+-- >>> unknownTileMap (fromJust (toArea (0,0,0,0))) TK.unknownId 2 2+-- PointArray.Array with size (2,2)+unknownTileMap :: Area -> ContentId TileKind -> X -> Y -> TileMap+unknownTileMap larea outerId rWidthMax rHeightMax =+  let unknownMap = PointArray.replicateA rWidthMax rHeightMax TK.unknownId+      outerUpdate = zip (areaInnerBorder larea) $ repeat outerId+  in unknownMap PointArray.// outerUpdate++-- | Initial complete global game state.+defStateGlobal :: Dungeon -> Dice.AbsDepth -> FactionDict -> COps+               -> HighScore.ScoreDict -> ContentId ModeKind -> DiscoveryKind+               -> State+defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh _sgameModeId+               _sdiscoKind =+  State+    { _sactorD = EM.empty+    , _sitemD = EM.empty+    , _sitemIxMap = EM.empty+    , _stime = timeZero+    , _sgold = 0+    , _sdiscoAspect = EM.empty+    , _sactorMaxSkills = EM.empty+    , ..+    }++-- | Initial empty state.+emptyState :: State+emptyState =+  State+    { _sdungeon = EM.empty+    , _stotalDepth = Dice.AbsDepth 0+    , _sactorD = EM.empty+    , _sitemD = EM.empty+    , _sitemIxMap = EM.empty+    , _sfactionD = EM.empty+    , _stime = timeZero+    , _scops = emptyCOps+    , _sgold = 0+    , _shigh = HighScore.empty+    , _sgameModeId = toEnum 0  -- the initial value is unused+    , _sdiscoKind = EM.empty+    , _sdiscoAspect = EM.empty+    , _sactorMaxSkills = EM.empty+    }++-- | Local state created by removing secret information from global+-- state components.+localFromGlobal :: State -> State+localFromGlobal State{..} =+  State+    { _sdungeon =+      EM.map (\Level{..} ->+              unknownLevel _scops lkind ldepth larea+                           lstair lescape lexpl lnight)+             _sdungeon+    , ..+    }++-- | Update dungeon data within state.+updateDungeon :: (Dungeon -> Dungeon) -> State -> State+updateDungeon f s = s {_sdungeon = f (_sdungeon s)}++-- | Update dungeon depth.+updateDepth :: (Dice.AbsDepth -> Dice.AbsDepth) -> State -> State+updateDepth f s = s {_stotalDepth = f (_stotalDepth s)}++-- | Update the actor dictionary.+updateActorD :: (ActorDict -> ActorDict) -> State -> State+{-# INLINE updateActorD #-}  -- just in case inliner goes hiwire+updateActorD f s = s {_sactorD = f (_sactorD s)}++-- | Update the item dictionary.+updateItemD :: (ItemDict -> ItemDict) -> State -> State+{-# INLINE updateItemD #-}+updateItemD f s = s {_sitemD = f (_sitemD s)}++-- | Update the item kind index map.+updateItemIxMap :: (ItemIxMap -> ItemIxMap) -> State -> State+updateItemIxMap f s = s {_sitemIxMap = f (_sitemIxMap s)}++-- | Update faction data within state.+updateFactionD :: (FactionDict -> FactionDict) -> State -> State+updateFactionD f s = s {_sfactionD = f (_sfactionD s)}++-- | Update global time within state.+updateTime :: (Time -> Time) -> State -> State+{-# INLINE updateTime #-}+updateTime f s = s {_stime = f (_stime s)}++-- | Update content data within state and recompute the cached data.+updateCOpsAndCachedData :: (COps -> COps) -> State -> State+updateCOpsAndCachedData f s =+  let s2 = s {_scops = f (_scops s)}+  in s2 {_sactorMaxSkills = maxSkillsInDungeon s2}++-- | Update total gold value in the dungeon.+updateGold :: (Int -> Int) -> State -> State+updateGold f s = s {_sgold = f (_sgold s)}++updateDiscoKind :: (DiscoveryKind -> DiscoveryKind) -> State -> State+updateDiscoKind f s = s {_sdiscoKind = f (_sdiscoKind s)}++updateDiscoAspect :: (DiscoveryAspect -> DiscoveryAspect) -> State -> State+updateDiscoAspect f s = s {_sdiscoAspect = f (_sdiscoAspect s)}++updateActorMaxSkills :: (ActorMaxSkills -> ActorMaxSkills) -> State -> State+updateActorMaxSkills f s = s {_sactorMaxSkills = f (_sactorMaxSkills s)}++getItemBody :: ItemId -> State -> Item+getItemBody iid s = sitemD s EM.! iid++-- This is best guess, including mean aspect record, so we can take into+-- consideration even the kind the item hides under.+aspectRecordFromItem :: ItemId -> Item -> State -> IA.AspectRecord+aspectRecordFromItem iid item s =+  let kindId = case jkind item of+        IdentityObvious ik -> ik+        IdentityCovered ix ik -> fromMaybe ik $ ix `EM.lookup` sdiscoKind s+      COps{coItemSpeedup} = scops s+      mean = IA.kmMean $ getKindMean kindId coItemSpeedup+  in fromMaybe mean $ EM.lookup iid $ sdiscoAspect s++aspectRecordFromIid :: ItemId -> State -> IA.AspectRecord+aspectRecordFromIid iid s = aspectRecordFromItem iid (getItemBody iid s) s++maxSkillsFromActor :: Actor -> State -> Ability.Skills+maxSkillsFromActor b s =+  let processIid (iid, (k, _)) = (IA.aSkills $ aspectRecordFromIid iid s, k)+      processBag sks = Ability.sumScaledSkills $ map processIid sks+  in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b)++maxSkillsInDungeon :: State -> ActorMaxSkills+maxSkillsInDungeon s =+  EM.map (`maxSkillsFromActor` s) $ sactorD s
+ engine-src/Game/LambdaHack/Common/Thread.hs view
@@ -0,0 +1,33 @@+-- | Keeping track of forked threads.+module Game.LambdaHack.Common.Thread+  ( forkChild, waitForChildren+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Control.Concurrent.Async+import Control.Concurrent.MVar++-- Swiped from <http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html>+-- Ported to Async to link exceptions, to let CI tests fail.++forkChild :: MVar [Async ()] -> IO () -> IO ()+forkChild children io = do+  a <- async io+  link a+  childs <- takeMVar children+  putMVar children (a : childs)++waitForChildren :: MVar [Async ()] -> IO ()+waitForChildren children = do+  cs <- takeMVar children+  case cs of+    [] -> do+      putMVar children []+      return ()+    m : ms -> do+      putMVar children ms+      wait m+      waitForChildren children
+ engine-src/Game/LambdaHack/Common/Tile.hs view
@@ -0,0 +1,401 @@+-- | Operations concerning dungeon level tiles.+--+-- Unlike for many other content types, there is no type @Tile@,+-- of particular concrete tiles in the dungeon,+-- corresponding to 'TileKind' (the type of kinds of terrain tiles).+-- This is because the tiles are too numerous and there's not enough+-- storage space for a well-rounded @Tile@ type, on one hand,+-- and on the other hand, tiles are accessed+-- too often in performance critical code+-- to try to compress their representation and/or recompute them.+-- Instead, of defining a @Tile@ type, we express various properties+-- of concrete tiles by arrays or sparse EnumMaps, as appropriate.+--+-- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m).+module Game.LambdaHack.Common.Tile+  ( -- * Tile property lookup speedup tables and their construction+    TileSpeedup(..), Tab(..), speedupTile+    -- * Speedup property lookups+  , isClear, isLit, isHideout, isWalkable, isDoor, isChangable+  , isSuspect, isHideAs, consideredByAI, isExplorable+  , isVeryOftenItem, isCommonItem, isOftenActor, isNoItem, isNoActor+  , isEasyOpen, isEmbed, isAquatic, alterMinSkill, alterMinWalk+    -- * Slow property lookups+  , kindHasFeature, openTo, closeTo, embeddedItems, revealAs+  , obscureAs, hideAs, buildAs+  , isEasyOpenKind, isOpenable, isClosable, isModifiable+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , createTab, createTabWithKey, accessTab, alterMinSkillKind, alterMinWalkKind+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Vector.Unboxed as U+import           Data.Word (Word8)++import           Game.LambdaHack.Content.ItemKind (ItemKind)+import           Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)+import qualified Game.LambdaHack.Content.TileKind as TK+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.ContentData+import           Game.LambdaHack.Definition.Defs++-- | A lot of tabulated maps from tile kind identifier to a property+-- of the tile kind.+data TileSpeedup = TileSpeedup+  { isClearTab          :: Tab Bool+  , isLitTab            :: Tab Bool+  , isHideoutTab        :: Tab Bool+  , isWalkableTab       :: Tab Bool+  , isDoorTab           :: Tab Bool+  , isOpenableTab       :: Tab Bool+  , isClosableTab       :: Tab Bool+  , isChangableTab      :: Tab Bool+  , isModifiableWithTab :: Tab Bool+  , isSuspectTab        :: Tab Bool+  , isHideAsTab         :: Tab Bool+  , consideredByAITab   :: Tab Bool+  , isVeryOftenItemTab  :: Tab Bool+  , isCommonItemTab     :: Tab Bool+  , isOftenActorTab     :: Tab Bool+  , isNoItemTab         :: Tab Bool+  , isNoActorTab        :: Tab Bool+  , isEasyOpenTab       :: Tab Bool+  , isEmbedTab          :: Tab Bool+  , isAquaticTab        :: Tab Bool+  , alterMinSkillTab    :: Tab Word8+  , alterMinWalkTab     :: Tab Word8+  }++-- Vectors of booleans can be slower than arrays, because they are not packed,+-- but with growing cache sizes they may as well turn out faster at some point.+-- The advantage of vectors are exposed internals, in particular unsafe+-- indexing. Also, in JS, bool arrays are obviously not packed.+-- An option: https://github.com/Bodigrim/bitvec+-- | A map morally indexed by @ContentId TileKind@.+newtype Tab a = Tab (U.Vector a)++createTab :: U.Unbox a => ContentData TileKind -> (TileKind -> a) -> Tab a+createTab cotile prop = Tab $ U.convert $ omapVector cotile prop++createTabWithKey :: U.Unbox a+                 => ContentData TileKind+                 -> (ContentId TileKind -> TileKind -> a)+                 -> Tab a+createTabWithKey cotile prop = Tab $ U.convert $ oimapVector cotile prop++-- Unsafe indexing is pretty safe here, because we guard the vector+-- with the newtype.+accessTab :: U.Unbox a => Tab a -> ContentId TileKind -> a+{-# INLINE accessTab #-}+accessTab (Tab tab) ki = tab `vectorUnboxedUnsafeIndex` contentIdIndex ki++speedupTile :: Bool -> ContentData TileKind -> TileSpeedup+speedupTile allClear cotile =+  -- Vectors pack bools as Word8 by default. No idea if the extra memory+  -- taken makes random lookups more or less efficient, so not optimizing+  -- further, until I have benchmarks.+  let isClearTab | allClear = createTab cotile $ (/= maxBound) . TK.talter+                 | otherwise = createTab cotile $ kindHasFeature TK.Clear+      isLitTab = createTab cotile $ not . kindHasFeature TK.Dark+      isHideoutTab = createTab cotile $ \tk ->+        kindHasFeature TK.Walkable tk  -- implies not unknown+        && kindHasFeature TK.Dark tk+      isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable+      isDoorTab = createTab cotile $ \tk ->+        let getTo (TK.OpenTo grp) acc = grp : acc+            getTo _ acc = acc+        in case foldr getTo [] $ TK.tfeature tk of+          [grp] | oisSingletonGroup cotile grp ->+            TK.isClosableKind $ okind cotile $ ouniqGroup cotile grp+          _ -> let getTo2 (TK.CloseTo grp) acc = grp : acc+                   getTo2 _ acc = acc+               in case foldr getTo2 [] $ TK.tfeature tk of+                 [grp] | oisSingletonGroup cotile grp ->+                   TK.isOpenableKind $ okind cotile $ ouniqGroup cotile grp+                 _ -> False+      isOpenableTab = createTab cotile TK.isOpenableKind+      isClosableTab = createTab cotile TK.isClosableKind+      isChangableTab = createTab cotile $ \tk ->+        let getTo TK.ChangeTo{} = True+            getTo _ = False+        in any getTo $ TK.tfeature tk+      isModifiableWithTab = createTab cotile $ \tk ->+        let getTo TK.OpenWith{} = True+            getTo TK.CloseWith{} = True+            getTo TK.ChangeWith{} = True+            getTo _ = False+        in any getTo $ TK.tfeature tk+      isSuspectTab = createTab cotile TK.isSuspectKind+      isHideAsTab = createTab cotile $ \tk ->+        let getTo TK.HideAs{} = True+            getTo _ = False+        in any getTo $ TK.tfeature tk+      consideredByAITab = createTab cotile $ kindHasFeature TK.ConsideredByAI+      isVeryOftenItemTab = createTab cotile $ kindHasFeature TK.VeryOftenItem+      isCommonItemTab = createTab cotile $ \tk ->+        kindHasFeature TK.OftenItem tk || kindHasFeature TK.VeryOftenItem tk+      isOftenActorTab = createTab cotile $ kindHasFeature TK.OftenActor+      isNoItemTab = createTab cotile $ kindHasFeature TK.NoItem+      isNoActorTab = createTab cotile $ kindHasFeature TK.NoActor+      isEasyOpenTab = createTab cotile isEasyOpenKind+      isEmbedTab = createTab cotile $ \tk ->+        let getTo TK.Embed{} = True+            getTo _ = False+        in any getTo $ TK.tfeature tk+      isAquaticTab = createTab cotile $ \tk ->+        maybe False (> 0) $ lookup TK.AQUATIC $ TK.tfreq tk+      alterMinSkillTab = createTabWithKey cotile alterMinSkillKind+      alterMinWalkTab = createTabWithKey cotile alterMinWalkKind+  in TileSpeedup {..}++-- Check that alter can be used, if not, @maxBound@.+-- For now, we assume only items with @Embed@ may have embedded items,+-- whether inserted at dungeon creation or later on.+-- This is used by UI and server to validate (sensibility of) altering.+-- See the comment for @alterMinWalkKind@ regarding @HideAs@.+alterMinSkillKind :: ContentId TileKind -> TileKind -> Word8+alterMinSkillKind _k tk =+  let getTo TK.OpenTo{} = True+      getTo TK.CloseTo{} = True+      getTo TK.ChangeTo{} = True+      getTo TK.OpenWith{} = True+      getTo TK.CloseWith{} = True+      getTo TK.ChangeWith{} = True+      getTo TK.HideAs{} = True  -- in case tile swapped, but server sends hidden+      getTo TK.RevealAs{} = True+      getTo TK.ObscureAs{} = True+      getTo TK.Embed{} = True+      getTo TK.ConsideredByAI = True+      getTo _ = False+  in if any getTo $ TK.tfeature tk then TK.talter tk else maxBound++-- How high alter skill is needed to make it walkable. If already+-- walkable, put @0@, if can't, put @maxBound@. Used only by AI and Bfs+-- We don't include @HideAs@, because it's very unlikely anybody swapped+-- the tile while AI was not looking so AI can assume it's still uninteresting.+-- Pathfinding in UI will also not show such tile as passable, which is OK.+-- If a human player has a suspicion the tile was swapped, he can check+-- it manually, disregarding the displayed path hints.+alterMinWalkKind :: ContentId TileKind -> TileKind -> Word8+alterMinWalkKind k tk =+  let getTo TK.OpenTo{} = True+-- enable when AI and humans can cope with unreachable areas+--      getTo TK.OpenWith{} = True+--        -- opening this may not be possible, but AI has to try, for there may+--        -- be no other path+      getTo TK.RevealAs{} = True+      getTo TK.ObscureAs{} = True+      getTo _ = False+  in if | kindHasFeature TK.Walkable tk -> 0+        | isUknownSpace k -> TK.talter tk+        | any getTo $ TK.tfeature tk -> TK.talter tk+        | otherwise -> maxBound++-- | Whether a tile does not block vision.+-- Essential for efficiency of "FOV", hence tabulated.+isClear :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isClear #-}+isClear TileSpeedup{isClearTab} = accessTab isClearTab++-- | Whether a tile has ambient light --- is lit on its own.+-- Essential for efficiency of "Perception", hence tabulated.+isLit :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isLit #-}+isLit TileSpeedup{isLitTab} = accessTab isLitTab++-- | Whether a tile is a good hideout: walkable and dark.+isHideout :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isHideout #-}+isHideout TileSpeedup{isHideoutTab} = accessTab isHideoutTab++-- | Whether actors can walk into a tile.+-- Essential for efficiency of pathfinding, hence tabulated.+isWalkable :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isWalkable #-}+isWalkable TileSpeedup{isWalkableTab} = accessTab isWalkableTab++-- | Whether a tile is a door, open or closed.+-- Essential for efficiency of pathfinding, hence tabulated.+isDoor :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isDoor #-}+isDoor TileSpeedup{isDoorTab} = accessTab isDoorTab++-- | Whether a tile kind (specified by its id) has an @OpenTo@ feature.+isOpenable :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isOpenable #-}+isOpenable TileSpeedup{isOpenableTab} = accessTab isOpenableTab++-- | Whether a tile kind (specified by its id) has a @CloseTo@ feature.+isClosable :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isClosable #-}+isClosable TileSpeedup{isClosableTab} = accessTab isClosableTab++-- | Whether a tile is changable.+isChangable :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isChangable #-}+isChangable TileSpeedup{isChangableTab} = accessTab isChangableTab++-- | Whether a tile is modifiable with some items.+isModifiableWith :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isModifiableWith #-}+isModifiableWith TileSpeedup{isModifiableWithTab} =+  accessTab isModifiableWithTab++-- | Whether a tile is suspect.+-- Essential for efficiency of pathfinding, hence tabulated.+isSuspect :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isSuspect #-}+isSuspect TileSpeedup{isSuspectTab} = accessTab isSuspectTab++isHideAs :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isHideAs #-}+isHideAs TileSpeedup{isHideAsTab} = accessTab isHideAsTab++consideredByAI :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE consideredByAI #-}+consideredByAI TileSpeedup{consideredByAITab} = accessTab consideredByAITab++-- | Whether one can easily explore a tile, possibly finding a treasure,+-- either spawned there or dropped there by a (dying from poison) foe.+-- Doors can't be explorable since revealing a secret tile+-- should not change it's explorable status. Also, door explorable status+-- should not depend on whether they are open or not, so that+-- a foe opening a door doesn't force us to backtrack to explore it.+-- Still, a foe that digs through a wall will affect our exploration counter+-- and if content lets walls contain threasure, such backtraking makes sense.+isExplorable :: TileSpeedup -> ContentId TileKind -> Bool+isExplorable coTileSpeedup t =+  isWalkable coTileSpeedup t && not (isDoor coTileSpeedup t)++isVeryOftenItem :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isVeryOftenItem #-}+isVeryOftenItem TileSpeedup{isVeryOftenItemTab} = accessTab isVeryOftenItemTab++isCommonItem :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isCommonItem #-}+isCommonItem TileSpeedup{isCommonItemTab} = accessTab isCommonItemTab++isOftenActor :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isOftenActor #-}+isOftenActor TileSpeedup{isOftenActorTab} = accessTab isOftenActorTab++isNoItem :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isNoItem #-}+isNoItem TileSpeedup{isNoItemTab} = accessTab isNoItemTab++isNoActor :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isNoActor #-}+isNoActor TileSpeedup{isNoActorTab} = accessTab isNoActorTab++-- | Whether a tile kind (specified by its id) has an @OpenTo@ feature+-- or is walkable even without opening.+isEasyOpen :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isEasyOpen #-}+isEasyOpen TileSpeedup{isEasyOpenTab} = accessTab isEasyOpenTab++isEmbed :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isEmbed #-}+isEmbed TileSpeedup{isEmbedTab} = accessTab isEmbedTab++isAquatic :: TileSpeedup -> ContentId TileKind -> Bool+{-# INLINE isAquatic #-}+isAquatic TileSpeedup{isAquaticTab} = accessTab isAquaticTab++alterMinSkill :: TileSpeedup -> ContentId TileKind -> Int+{-# INLINE alterMinSkill #-}+alterMinSkill TileSpeedup{alterMinSkillTab} =+  fromEnum . accessTab alterMinSkillTab++alterMinWalk :: TileSpeedup -> ContentId TileKind -> Int+{-# INLINE alterMinWalk #-}+alterMinWalk TileSpeedup{alterMinWalkTab} =+  fromEnum . accessTab alterMinWalkTab++-- | Whether a tile kind has the given feature.+kindHasFeature :: TK.Feature -> TileKind -> Bool+{-# INLINE kindHasFeature #-}+kindHasFeature f t = f `elem` TK.tfeature t++openTo :: ContentData TileKind -> ContentId TileKind -> Rnd (ContentId TileKind)+openTo cotile t = do+  let getTo (TK.OpenTo grp) acc = grp : acc+      getTo _ acc = acc+  case foldr getTo [] $ TK.tfeature $ okind cotile t of+    [grp] -> fromMaybe (error $ "" `showFailure` grp)+             <$> opick cotile grp (const True)+    _ -> return t++closeTo :: ContentData TileKind -> ContentId TileKind+        -> Rnd (ContentId TileKind)+closeTo cotile t = do+  let getTo (TK.CloseTo grp) acc = grp : acc+      getTo _ acc = acc+  case foldr getTo [] $ TK.tfeature $ okind cotile t of+    [grp] -> fromMaybe (error $ "" `showFailure` grp)+             <$> opick cotile grp (const True)+    _ -> return t++embeddedItems :: ContentData TileKind -> ContentId TileKind+              -> [GroupName ItemKind]+embeddedItems cotile t =+  let getTo (TK.Embed igrp) acc = igrp : acc+      getTo _ acc = acc+  in foldr getTo [] $ TK.tfeature $ okind cotile t++revealAs :: ContentData TileKind -> ContentId TileKind+         -> Rnd (ContentId TileKind)+revealAs cotile t = do+  let getTo (TK.RevealAs grp) acc = grp : acc+      getTo _ acc = acc+  case foldr getTo [] $ TK.tfeature $ okind cotile t of+    [] -> return t+    groups -> do+      grp <- oneOf groups+      fromMaybe (error $ "" `showFailure` grp) <$> opick cotile grp (const True)++obscureAs :: ContentData TileKind -> ContentId TileKind+          -> Rnd (ContentId TileKind)+obscureAs cotile t = do+  let getTo (TK.ObscureAs grp) acc = grp : acc+      getTo _ acc = acc+  case foldr getTo [] $ TK.tfeature $ okind cotile $ buildAs cotile t of+    [] -> return t+    groups -> do+      grp <- oneOf groups+      fromMaybe (error $ "" `showFailure` grp) <$> opick cotile grp (const True)++hideAs :: ContentData TileKind -> ContentId TileKind+       -> Maybe (ContentId TileKind)+hideAs cotile t =+  let getTo TK.HideAs{} = True+      getTo _ = False+  in case find getTo $ TK.tfeature $ okind cotile t of+       Just (TK.HideAs grp) -> Just $ ouniqGroup cotile grp+       _ -> Nothing++buildAs :: ContentData TileKind -> ContentId TileKind -> ContentId TileKind+buildAs cotile t =+  let getTo TK.BuildAs{} = True+      getTo _ = False+  in case find getTo $ TK.tfeature $ okind cotile t of+       Just (TK.BuildAs grp) -> ouniqGroup cotile grp+       _ -> t++isEasyOpenKind :: TileKind -> Bool+isEasyOpenKind tk =+  let getTo TK.OpenTo{} = True+      getTo TK.Walkable = True  -- very easy open+      getTo _ = False+  in TK.talter tk < 10 && any getTo (TK.tfeature tk)++isModifiable :: TileSpeedup -> ContentId TileKind -> Bool+isModifiable coTileSpeedup t = isOpenable coTileSpeedup t+                               || isClosable coTileSpeedup t+                               || isChangable coTileSpeedup t+                               || isModifiableWith coTileSpeedup t+                               || isSuspect coTileSpeedup t
+ engine-src/Game/LambdaHack/Common/Time.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}+-- | Game time and speed.+module Game.LambdaHack.Common.Time+  ( Time, timeTicks+  , timeZero, timeEpsilon, timeClip, timeTurn, timeSecond, clipsInTurn+  , absoluteTimeAdd, absoluteTimeSubtract, absoluteTimeNegate+  , timeFit, timeFitUp, timeRecent5+  , Delta(..), timeShift, timeDeltaToFrom, timeDeltaAdd, timeDeltaSubtract+  , timeDeltaReverse, timeDeltaScale, timeDeltaPercent, timeDeltaDiv+  , timeDeltaToDigit, timeDeltaInSecondsText+  , Speed, toSpeed, fromSpeed, minSpeed, displaySpeed+  , speedWalk, speedLimp, speedThrust, modifyDamageBySpeed, speedScale, speedAdd+  , ticksPerMeter, speedFromWeight, rangeFromSpeedAndLinger+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , _timeTick, turnsInSecond, sInMs, minimalSpeed, rangeFromSpeed+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.Char as Char+import           Data.Int (Int64)++import Game.LambdaHack.Common.Misc++-- | Game time in ticks. The time dimension.+-- One tick is 1 microsecond (one millionth of a second),+-- one turn is 0.5 s.+newtype Time = Time {timeTicks :: Int64}+  deriving (Show, Eq, Ord, Binary)++-- | Start of the game time, or zero lenght time interval.+timeZero :: Time+timeZero = Time 0++-- | The smallest unit of time. Should not be exported and used elsewhere,+-- because the proportion of turn to tick is an implementation detail.+-- The significance of this detail is only that it determines resolution+-- of the time dimension.+_timeTick :: Time+_timeTick = Time 1++-- | An infinitesimal time period.+timeEpsilon :: Time+timeEpsilon = _timeTick++-- | At least once per clip all moves are resolved+-- and a frame or a frame delay is generated.+-- Currently one clip is 0.05 s, but it may change,+-- and the code should not depend on this fixed value.+timeClip :: Time+timeClip = Time 50000++-- | One turn is 0.5 s. The code may depend on that.+-- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m).+timeTurn :: Time+timeTurn = Time 500000++-- | This many ticks fits in a single second.+timeSecond :: Time+timeSecond = Time $ timeTicks timeTurn * turnsInSecond++-- | This many turns fit in a single second.+turnsInSecond :: Int64+turnsInSecond = 2++-- | This many clips fit in one turn. Determines the resolution+-- of actor move sampling and display updates.+clipsInTurn :: Int+clipsInTurn =+  let r = timeTurn `timeFit` timeClip+  in assert (r >= 5) r++-- | Absolute time addition, e.g., for summing the total game session time+-- from the times of individual games.+absoluteTimeAdd :: Time -> Time -> Time+{-# INLINE absoluteTimeAdd #-}+absoluteTimeAdd (Time t1) (Time t2) = Time (t1 + t2)++absoluteTimeSubtract :: Time -> Time -> Time+{-# INLINE absoluteTimeSubtract #-}+absoluteTimeSubtract (Time t1) (Time t2) = Time (t1 - t2)++-- | Absolute time negation. To be used for reversing time flow,+-- e.g., for comparing absolute times in the reverse order.+absoluteTimeNegate :: Time -> Time+{-# INLINE absoluteTimeNegate #-}+absoluteTimeNegate (Time t) = Time (-t)++-- | How many time intervals of the latter kind fits in an interval+-- of the former kind.+timeFit :: Time -> Time -> Int+{-# INLINE timeFit #-}+timeFit (Time t1) (Time t2) = fromEnum $ t1 `div` t2++-- | How many time intervals of the latter kind cover an interval+-- of the former kind (rounded up).+timeFitUp :: Time -> Time -> Int+{-# INLINE timeFitUp #-}+timeFitUp (Time t1) (Time t2) = fromEnum $ t1 `divUp` t2++timeRecent5 :: Time -> Time -> Bool+timeRecent5 localTime time = timeDeltaToFrom localTime time+                             < timeDeltaScale (Delta timeTurn) 5++-- | One-dimentional vectors. Introduced to tell apart the 2 uses of Time:+-- as an absolute game time and as an increment.+newtype Delta a = Delta a+  deriving (Show, Eq, Ord, Binary, Functor)++-- | Shifting an absolute time by a time vector.+timeShift :: Time -> Delta Time -> Time+{-# INLINE timeShift #-}+timeShift (Time t1) (Delta (Time t2)) = Time (t1 + t2)++-- | Time time vector between the second and the first absolute times.+-- The arguments are in the same order as in the underlying scalar subtraction.+timeDeltaToFrom :: Time -> Time -> Delta Time+{-# INLINE timeDeltaToFrom #-}+timeDeltaToFrom (Time t1) (Time t2) = Delta $ Time (t1 - t2)++-- | Addition of time deltas.+timeDeltaAdd :: Delta Time -> Delta Time -> Delta Time+{-# INLINE timeDeltaAdd #-}+timeDeltaAdd (Delta (Time t1)) (Delta (Time t2)) = Delta $ Time (t1 - t2)++-- | Subtraction of time deltas.+-- The arguments are in the same order as in the underlying scalar subtraction.+timeDeltaSubtract :: Delta Time -> Delta Time -> Delta Time+{-# INLINE timeDeltaSubtract #-}+timeDeltaSubtract (Delta (Time t1)) (Delta (Time t2)) = Delta $ Time (t1 - t2)++-- | Reverse a time vector.+timeDeltaReverse :: Delta Time -> Delta Time+{-# INLINE timeDeltaReverse #-}+timeDeltaReverse (Delta (Time t)) = Delta (Time (-t))++-- | Scale the time vector by an @Int@ scalar value.+timeDeltaScale :: Delta Time -> Int -> Delta Time+{-# INLINE timeDeltaScale #-}+timeDeltaScale (Delta (Time t)) s = Delta (Time (t * into @Int64 s))++-- | Take the given percent of the time vector.+timeDeltaPercent :: Delta Time -> Int -> Delta Time+{-# INLINE timeDeltaPercent #-}+timeDeltaPercent (Delta (Time t)) s =+  Delta (Time (t * into @Int64 s `div` 100))++-- | Divide a time vector.+timeDeltaDiv :: Delta Time -> Int -> Delta Time+{-# INLINE timeDeltaDiv #-}+timeDeltaDiv (Delta (Time t)) n = Delta (Time (t `div` into @Int64 n))++-- | Represent the main 10 thresholds of a time range by digits,+-- given the total length of the time range.+timeDeltaToDigit :: Delta Time -> Delta Time -> Char+{-# INLINE timeDeltaToDigit #-}+timeDeltaToDigit (Delta (Time maxT)) (Delta (Time t)) =+  let n = (20 * t) `div` maxT+      k = (n + 1) `div` 2+      digit | k > 9     = '9'+            | k < 1     = '1'+            | otherwise = Char.intToDigit $ fromEnum k+  in digit++-- @oneM@ times the number of seconds represented by the time delta+timeDeltaInSeconds :: Delta Time -> Int64+timeDeltaInSeconds (Delta (Time dt)) = oneM * dt `div` timeTicks timeSecond++timeDeltaInSecondsText :: Delta Time -> Text+timeDeltaInSecondsText delta = show64With2 (timeDeltaInSeconds delta) <> "s"++-- | Speed in meters per 1 million seconds (m/Ms).+-- Actors at normal speed (2 m/s) take one time turn (0.5 s)+-- to make one step (move one tile, which is 1 m by 1 m).+newtype Speed = Speed Int64+  deriving (Eq, Ord, Binary)++instance Show Speed where+  show s = show $ fromSpeed s++-- | Number of seconds in a mega-second.+sInMs :: Int64+sInMs = 1000000++-- | Constructor for content definitions.+toSpeed :: Int -> Speed+{-# INLINE toSpeed #-}+toSpeed s = Speed $ into @Int64 s * sInMs `div` 10++-- | Readable representation of speed in the format used in content definitions.+fromSpeed :: Speed -> Int+{-# INLINE fromSpeed #-}+fromSpeed (Speed s) = fromEnum $ s * 10 `div` sInMs++minSpeed :: Int+minSpeed = 5++-- | Pretty-print speed given in the format used in content definitions.+displaySpeed :: Int -> String+displaySpeed kRaw =+  let k = max minSpeed kRaw+      l = k `div` 10+      x = k - l * 10+  in show l+     <> (if x == 0 then "" else "." <> show x)+     <> "m/s"++-- | The minimal speed is half a meter (half a step across a tile)+-- per second (two standard turns, which the time span during which+-- projectile moves, unless it has modified linger value).+-- This is four times slower than standard human movement speed.+--+-- It needen't be lower, because @rangeFromSpeed@ gives 0 steps+-- with such speed, so the actor's trajectory is empty, so it drops down+-- at once. Twice that speed already moves a normal projectile one step+-- before it stops. It shouldn't be lower or a slow actor would incur+-- such a time debt for performing a single action that he'd be paralyzed+-- for many turns, e.g., leaving his dead body on the screen for very long.+minimalSpeed :: Int64+minimalSpeed =+  let Speed msp = toSpeed minSpeed+  in assert (msp == sInMs `div` 2) msp++-- | Fast walk speed (2 m/s) that suffices to move one tile in one turn.+speedWalk :: Speed+speedWalk = Speed $ 2 * sInMs++-- | Limp speed (1 m/s) that suffices to move one tile in two turns.+-- This is the minimal speed for projectiles to fly just one space and drop.+speedLimp :: Speed+speedLimp = Speed sInMs++-- | Sword thrust speed (10 m/s). Base weapon damages, both melee and ranged,+-- are given assuming this speed and ranged damage is modified+-- accordingly when projectile speeds differ. Differences in melee+-- weapon swing speeds are captured in damage bonuses instead,+-- since many other factors influence total damage.+--+-- Billiard ball is 25 m/s, sword swing at the tip is 35 m/s,+-- medieval bow is 70 m/s, AK47 is 700 m/s.+speedThrust :: Speed+speedThrust = Speed $ 10 * sInMs++-- | Modify damage when projectiles is at a non-standard speed.+-- Energy and so damage is proportional to the square of speed,+-- hence the formula.+modifyDamageBySpeed :: Int64 -> Speed -> Int64+modifyDamageBySpeed dmg (Speed s) =+  let Speed sThrust = speedThrust+  in if s <= minimalSpeed+     then 0  -- needed mostly not to display useless ranged damage+     else round $  -- Double, because overflows Int64+       int64ToDouble dmg * int64ToDouble s ^ (2 :: Int)+       / int64ToDouble sThrust ^ (2 :: Int)++-- | Scale speed by a scalar value.+speedScale :: Rational -> Speed -> Speed+{-# INLINE speedScale #-}+speedScale s (Speed v) =+  Speed (round $ (fromIntegralWrap :: Int64 -> Rational) v * s)++-- | Speed addition.+speedAdd :: Speed -> Speed -> Speed+{-# INLINE speedAdd #-}+speedAdd (Speed s1) (Speed s2) = Speed (s1 + s2)++-- | The number of time ticks it takes to walk 1 meter at the given speed.+ticksPerMeter :: Speed -> Delta Time+{-# INLINE ticksPerMeter #-}+ticksPerMeter (Speed v) =+  -- Prevent division by zero or infinite time taken for any action.+  Delta $ Time $ timeTicks timeSecond * sInMs `divUp` max minimalSpeed v++-- | Calculate projectile speed from item weight in grams+-- and velocity percent modifier.+-- See <https://github.com/LambdaHack/LambdaHack/wiki/Item-statistics>.+speedFromWeight :: Int -> Int -> Speed+speedFromWeight !weight !throwVelocity =+  let w = into @Int64 weight+      mpMs | w < 250 = sInMs * 20+           | w < 1500 = sInMs * 20 * 1250 `div` (w + 1000)+           | w < 10500 = sInMs * (11500 - w) `div` 1000+           | otherwise = minimalSpeed * 2  -- move one step and drop+      v = mpMs * into @Int64 throwVelocity `div` 100+      -- We round down to the nearest multiple of 2M (unless the speed+      -- is very low), to ensure both turns of flight cover the same distance+      -- and that the speed matches the distance traveled exactly.+      multiple2M = if v > 2 * sInMs+                   then 2 * sInMs * (v `div` (2 * sInMs))+                   else v+  in Speed $ max minimalSpeed multiple2M++-- | Calculate maximum range in meters of a projectile from its speed.+-- See <https://github.com/LambdaHack/LambdaHack/wiki/Item-statistics>.+-- With this formula, each projectile flies for at most 1 second,+-- that is 2 standard turns, and then drops to the ground.+rangeFromSpeed :: Speed -> Int+{-# INLINE rangeFromSpeed #-}+rangeFromSpeed (Speed v) = fromEnum $ v `div` sInMs++-- | Calculate maximum range taking into account the linger percentage.+rangeFromSpeedAndLinger :: Speed -> Int -> Int+rangeFromSpeedAndLinger !speed !throwLinger =+  let range = rangeFromSpeed speed+  in throwLinger * range `divUp` 100
+ engine-src/Game/LambdaHack/Common/Types.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Abstract identifiers for the main types in the engine. This is imported+-- by modules that don't need to know the internal structure+-- of the types. As a side effect, this prevents mutual dependencies+-- among modules.+module Game.LambdaHack.Common.Types+  ( ItemId, FactionId, LevelId, ActorId+  , Container(..)+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Data.Binary+import Data.Hashable+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Point+import Game.LambdaHack.Definition.Defs++-- | A unique identifier of an item in the dungeon.+newtype ItemId = ItemId Int+  deriving (Show, Eq, Ord, Enum, Binary)++-- | A unique identifier of a faction in a game. It's assigned in the order+-- from game mode roster, starting from one. We keep the @FactionId@+-- and @TeamContinuity@ types separate mostly to let @FactionId@ reflect+-- the order, which influences starting faction positions, etc.+-- We use @TeamContinuity@ for dictionaries containing teams that may+-- or may not be active factions in the current game, while @FactionId@ are+-- used only for factions in the game (in particular, because they vary+-- depending on order in game mode roster, while @TeamContinuity@ are stable).+newtype FactionId = FactionId Int+  deriving (Show, Eq, Ord, Enum, Hashable, Binary)++-- | Abstract level identifiers.+newtype LevelId = LevelId Int+  deriving (Show, Eq, Ord, Hashable, Binary)++instance Enum LevelId where+  fromEnum (LevelId n) = n+  toEnum = LevelId  -- picks the main branch of the dungeon++-- | A unique identifier of an actor in the dungeon.+newtype ActorId = ActorId Int+  deriving (Show, Eq, Ord, Enum, Binary)++-- | Item container type.+data Container =+    CFloor LevelId Point+  | CEmbed LevelId Point+  | CActor ActorId CStore+  | CTrunk FactionId LevelId Point   -- ^ for bootstrapping actor bodies+  deriving (Show, Eq, Ord, Generic)++instance Binary Container
+ engine-src/Game/LambdaHack/Common/Vector.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Basic operations on bounded 2D vectors, with an efficient, but not 1-1+-- and not monotonic @Enum@ instance.+module Game.LambdaHack.Common.Vector+  ( Vector(..), VectorI+  , isUnit, neg, chessDistVector, euclidDistSqVector+  , moves, movesCardinal, movesCardinalI, movesDiagonal, movesDiagonalI+  , compassText, vicinityBounded, vicinityUnsafe+  , vicinityCardinal, vicinityCardinalUnsafe, squareUnsafeSet+  , shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded+  , vectorToFrom, computeTrajectory+  , RadianAngle, rotate, towards+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , longMoveTexts, movesSquare, pathToTrajectory+  , normalize, normalizeVector+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.DeepSeq+import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Int (Int32)+import qualified Data.IntSet as IS+import qualified Data.Primitive.PrimArray as PA+import           GHC.Generics (Generic)++import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Definition.Defs++-- | 2D vectors in cartesian representation. Coordinates grow to the right+-- and down, so that the (1, 1) vector points to the bottom-right corner+-- of the screen.+data Vector = Vector+  { vx :: X+  , vy :: Y+  }+  deriving (Show, Read, Eq, Ord, Generic)++instance Binary Vector where+  put = put . (toIntegralCrash :: Int -> Int32) . fromEnum+  get = fmap (toEnum . (fromIntegralWrap :: Int32 -> Int)) get+    -- `fromIntegralWrap` is fine here, because we converted the integer+    -- in the opposite direction first, so it fits even in 31 bit `Int`++-- Note that the conversion is not monotonic wrt the natural @Ord@ instance,+-- to keep it in sync with Point.+instance Enum Vector where+  fromEnum Vector{..} =+    let !xsize = PA.indexPrimArray speedupHackXSize 0+    in vx + vy * xsize+  toEnum n =+    let !xsize = PA.indexPrimArray speedupHackXSize 0+        !xsizeHalf = xsize `div` 2+        (!y, !x) = n `quotRem` xsize+        (!vx, !vy) | x >= xsizeHalf = (x - xsize, y + 1)+                   | x <= - xsizeHalf = (x + xsize, y - 1)+                   | otherwise = (x, y)+    in Vector{..}++instance NFData Vector++-- | Enumeration representation of @Vector@.+type VectorI = Int++-- | Tells if a vector has length 1 in the chessboard metric.+isUnit :: Vector -> Bool+{-# INLINE isUnit #-}+isUnit v = chessDistVector v == 1++-- | Reverse an arbirary vector.+neg :: Vector -> Vector+{-# INLINE neg #-}+neg (Vector vx vy) = Vector (-vx) (-vy)++-- | The lenght of a vector in the chessboard metric,+-- where diagonal moves cost 1.+chessDistVector :: Vector -> Int+{-# INLINE chessDistVector #-}+chessDistVector (Vector x y) = max (abs x) (abs y)++-- | Squared euclidean distance between two vectors.+euclidDistSqVector :: Vector -> Vector -> Int+euclidDistSqVector (Vector x0 y0) (Vector x1 y1) =+  (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int)++-- | Vectors of all unit moves in the chessboard metric,+-- clockwise, starting north-west.+moves :: [Vector]+moves =+  map (uncurry Vector)+    [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)]++-- | Vectors of all cardinal direction unit moves, clockwise, starting north.+movesCardinal :: [Vector]+movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)]++movesCardinalI :: [VectorI]+movesCardinalI = map fromEnum movesCardinal++-- | Vectors of all diagonal direction unit moves, clockwise, starting north.+movesDiagonal :: [Vector]+movesDiagonal = map (uncurry Vector) [(-1, -1), (1, -1), (1, 1), (-1, 1)]++movesDiagonalI :: [VectorI]+movesDiagonalI = map fromEnum movesDiagonal++-- moveTexts :: [Text]+-- moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"]++longMoveTexts :: [Text]+longMoveTexts = [ "northwest", "north", "northeast", "east"+                , "southeast", "south", "southwest", "west" ]++compassText :: Vector -> Text+compassText v = let m = EM.fromList $ zip moves longMoveTexts+                    assFail = error $ "not a unit vector" `showFailure` v+                in EM.findWithDefault assFail v m++-- | All (8 at most) closest neighbours of a point within an area.+vicinityBounded :: X -> Y   -- ^ limit the search to this area+                -> Point    -- ^ position to find neighbours of+                -> [Point]+vicinityBounded rWidthMax rHeightMax p =+  if insideP (1, 1, rWidthMax - 2, rHeightMax - 2) p+  then vicinityUnsafe p+  else [ res | dxy <- moves+             , let res = shift p dxy+             , insideP (0, 0, rWidthMax - 1, rHeightMax - 1) res ]++vicinityUnsafe :: Point -> [Point]+{-# INLINE vicinityUnsafe #-}+vicinityUnsafe p = [ shift p dxy | dxy <- moves ]++-- | All (4 at most) cardinal direction neighbours of a point within an area.+vicinityCardinal :: X -> Y   -- ^ limit the search to this area+                 -> Point    -- ^ position to find neighbours of+                 -> [Point]+vicinityCardinal rWidthMax rHeightMax p =+  [ res | dxy <- movesCardinal+        , let res = shift p dxy+        , insideP (0, 0, rWidthMax - 1, rHeightMax - 1) res ]++vicinityCardinalUnsafe :: Point -> [Point]+vicinityCardinalUnsafe p = [ shift p dxy | dxy <- movesCardinal ]++-- Ascending list; includes the origin.+movesSquare :: [VectorI]+movesSquare = map (fromEnum . uncurry Vector)+                  [ (-1, -1), (0, -1), (1, -1)+                  , (-1, 0), (0, 0), (1, 0)+                  , (-1, 1), (0, 1), (1, 1) ]++squareUnsafeSet :: Point -> ES.EnumSet Point+{-# INLINE squareUnsafeSet #-}+squareUnsafeSet p =+  ES.intSetToEnumSet $ IS.fromDistinctAscList $ map (fromEnum p +) movesSquare++-- | Translate a point by a vector.+shift :: Point -> Vector -> Point+{-# INLINE shift #-}+shift (Point x0 y0) (Vector x1 y1) = Point (x0 + x1) (y0 + y1)++-- | Translate a point by a vector, but only if the result fits in an area.+shiftBounded :: X -> Y -> Point -> Vector -> Point+shiftBounded rWidthMax rHeightMax pos v@(Vector xv yv) =+  if insideP (-xv, -yv, rWidthMax - xv - 1, rHeightMax - yv - 1) pos+  then shift pos v+  else pos++-- | A list of points that a list of vectors leads to.+trajectoryToPath :: Point -> [Vector] -> [Point]+trajectoryToPath _ [] = []+trajectoryToPath start (v : vs) = let next = shift start v+                                  in next : trajectoryToPath next vs++-- | A list of points that a list of vectors leads to, bounded by level size.+trajectoryToPathBounded :: X -> Y -> Point -> [Vector] -> [Point]+trajectoryToPathBounded _ _ _ [] = []+trajectoryToPathBounded rWidthMax rHeightMax start (v : vs) =+  let next = shiftBounded rWidthMax rHeightMax start v+  in next : trajectoryToPathBounded rWidthMax rHeightMax next vs++-- | The vector between the second point and the first. We have+--+-- > shift pos1 (pos2 `vectorToFrom` pos1) == pos2+--+-- The arguments are in the same order as in the underlying scalar subtraction.+vectorToFrom :: Point -> Point -> Vector+{-# INLINE vectorToFrom #-}+vectorToFrom (Point x0 y0) (Point x1 y1) = Vector (x0 - x1) (y0 - y1)++-- | A list of vectors between a list of points.+pathToTrajectory :: [Point] -> [Vector]+pathToTrajectory [] = []+pathToTrajectory lp1@(_ : lp2) = zipWith vectorToFrom lp2 lp1++computeTrajectory :: Int -> Int -> Int -> [Point] -> ([Vector], (Speed, Int))+computeTrajectory weight throwVelocity throwLinger path =+  let speed = speedFromWeight weight throwVelocity+      trange = rangeFromSpeedAndLinger speed throwLinger+      btrajectory = pathToTrajectory $ take (trange + 1) path+  in (btrajectory, (speed, trange))++type RadianAngle = Double++-- | Rotate a vector by the given angle (expressed in radians)+-- counterclockwise and return a unit vector approximately in the resulting+-- direction.+rotate :: RadianAngle -> Vector -> Vector+rotate angle (Vector x' y') =+  let x = intToDouble x'+      y = intToDouble y'+      -- Minus before the angle comes from our coordinates being+      -- mirrored along the X axis (Y coordinates grow going downwards).+      dx = x * cos (-angle) - y * sin (-angle)+      dy = x * sin (-angle) + y * cos (-angle)+  in normalize dx dy++-- | Given a vector of arbitrary non-zero length, produce a unit vector+-- that points in the same direction (in the chessboard metric).+-- Of several equally good directions it picks one of those that visually+-- (in the euclidean metric) maximally align with the original vector.+normalize :: Double -> Double -> Vector+normalize dx dy =+  assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `swith` (dx, dy)) $+  let angle :: Double+      angle = atan (dy / dx) / (pi / 2)+      dxy | angle <= -0.75 && angle >= -1.25 = (0, -1)+          | angle <= -0.25 = (1, -1)+          | angle <= 0.25  = (1, 0)+          | angle <= 0.75  = (1, 1)+          | angle <= 1.25  = (0, 1)+          | otherwise = error $ "impossible angle" `showFailure` (dx, dy, angle)+  in if dx >= 0+     then uncurry Vector dxy+     else neg $ uncurry Vector dxy++normalizeVector :: Vector -> Vector+normalizeVector v@(Vector vx vy) =+  let res = normalize (intToDouble vx) (intToDouble vy)+  in assert (not (isUnit v) || v == res+             `blame` "unit vector gets untrivially normalized"+             `swith` (v, res))+     res++-- | Given two distinct positions, determine the direction (a unit vector)+-- in which one should move from the first in order to get closer+-- to the second. Ignores obstacles. Of several equally good directions+-- (in the chessboard metric) it picks one of those that visually+-- (in the euclidean metric) maximally align with the vector between+-- the two points.+towards :: Point -> Point -> Vector+towards pos0 pos1 =+  assert (pos0 /= pos1 `blame` "towards self" `swith` (pos0, pos1))+  $ normalizeVector $ pos1 `vectorToFrom` pos0
+ engine-src/Game/LambdaHack/Server.hs view
@@ -0,0 +1,22 @@+-- | Semantics of requests that are sent by clients to the server,+-- in terms of game state changes and responses to be sent to the clients.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Server+  ( -- * Re-exported from "Game.LambdaHack.Server.LoopM"+    loopSer+    -- * Re-exported from "Game.LambdaHack.Server.ProtocolM"+  , ChanServer (..)+    -- * Re-exported from "Game.LambdaHack.Server.Commandline"+  , serverOptionsPI+    -- * Re-exported from "Game.LambdaHack.Server.ServerOptions"+  , ServerOptions(..)+  ) where++import Prelude ()++import Game.LambdaHack.Server.Commandline (serverOptionsPI)+import Game.LambdaHack.Server.LoopM (loopSer)+import Game.LambdaHack.Server.ProtocolM+import Game.LambdaHack.Server.ServerOptions
+ engine-src/Game/LambdaHack/Server/BroadcastAtomic.hs view
@@ -0,0 +1,409 @@+{-# LANGUAGE TupleSections #-}+-- | Sending atomic commands to clients and executing them on the server.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Server.BroadcastAtomic+  ( handleAndBroadcast, sendPer, handleCmdAtomicServer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , cmdItemsFromIids, hearUpdAtomic, hearSfxAtomic, filterHear, atomicForget+  , atomicRemember+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified NLP.Miniutter.English as MU++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.TileKind (isUknownSpace)+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.ProtocolM+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++--storeUndo :: MonadServer m => CmdAtomic -> m ()+--storeUndo _atomic =+--  maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser})+--    $ Nothing   -- undoCmdAtomic atomic++handleCmdAtomicServer :: MonadServerAtomic m+                      => UpdAtomic -> m (PosAtomic, [UpdAtomic], Bool)+handleCmdAtomicServer cmd = do+  ps <- posUpdAtomic cmd+  atomicBroken <- breakUpdAtomic cmd+    -- needs to be done before the states are changed and may make no sense+  executedOnServer <- if seenAtomicSer ps+                      then execUpdAtomicSer cmd+                      else return False+  return (ps, atomicBroken, executedOnServer)++-- | Send an atomic action to all clients that can see it.+handleAndBroadcast :: (MonadServerAtomic m, MonadServerComm m)+                   => PosAtomic -> [UpdAtomic] -> CmdAtomic -> m ()+handleAndBroadcast ps atomicBroken atomic = do+  -- This is calculated in the server State before action (simulating+  -- current client State, because action has not been applied+  -- on the client yet).+  -- E.g., actor's position in @breakUpdAtomic@ is assumed to be pre-action.+  -- To get rid of breakUpdAtomic we'd need to send only Spot and Lose+  -- commands instead of Move and Displace (plus Sfx for Displace).+  -- So this only makes sense when we switch to sending state diffs.+  knowEvents <- getsServer $ sknowEvents . soptions+  sperFidOld <- getsServer sperFid+  -- Send some actions to the clients, one faction at a time.+  let sendAtomic fid (UpdAtomic cmd) = do+        let iids = iidUpdAtomic cmd+        s <- getState+        sClient <- getsServer $ (EM.! fid) . sclientStates+        mapM_ (sendUpdateCheck fid) $ cmdItemsFromIids iids sClient s+        sendUpdate fid cmd+      sendAtomic fid (SfxAtomic sfx) = do+        let iids = iidSfxAtomic sfx+        s <- getState+        sClient <- getsServer $ (EM.! fid) . sclientStates+        mapM_ (sendUpdateCheck fid) $ cmdItemsFromIids iids sClient s+        sendSfx fid sfx+      breakSend fid perFid = case lidOfPos ps of+        Nothing -> return ()+        Just lidOriginal -> do+          psBroken <- mapM posUpdAtomic atomicBroken+          case psBroken of+            _ : _ -> do+              let send2 (cmd2, ps2) =+                    when (seenAtomicCli knowEvents fid perFid ps2) $+                      sendAtomic fid (UpdAtomic cmd2)+              mapM_ send2 $ zip atomicBroken psBroken+            [] -> do  -- hear only here; broken commands are never loud+              -- At most @minusM@ applied total over a single actor move,+              -- to avoid distress as if wounded (which is measured via deltas).+              -- So, if faction hits an enemy and it yells, hearnig yell will+              -- not decrease calm over the decrease from hearing strike.+              -- This may accumulate over time, though, to eventually wake up+              -- sleeping actors.+              let drainCalmOnce aid = do+                    b <- getsState $ getActorBody aid+                    when (deltaBenign $ bcalmDelta b) $+                      execUpdAtomic $ UpdRefillCalm aid minusM+                  leaderDistance pos = do+                    mleader <- getsState $ gleader . (EM.! fid) . sfactionD+                    case mleader of+                      Nothing -> return Nothing+                      Just leader -> do+                        b <- getsState $ getActorBody leader+                        -- Leader's hearing as relevant as of any other actor,+                        -- which prevents changing leader just to get hearing+                        -- intel. However, leader's position affects accuracy+                        -- of the distance to noise hints.+                        return $ Just $ max 0 $ min 5 $ flip (-) 1 $ floor+                               $ sqrt $ intToDouble $ chessDist pos (bpos b)+              -- Projectiles never hear, for speed and simplicity,+              -- even though they sometimes see. There are flying cameras,+              -- but no microphones --- drones make too much noise themselves.+              as <- getsState $ fidActorRegularAssocs fid lidOriginal+              case atomic of+                UpdAtomic cmd -> do+                  (profound, mpos) <- hearUpdAtomic cmd+                  case mpos of+                    Nothing | profound ->+                      sendUpdate fid $ UpdHearFid fid Nothing+                                     $ HearUpd cmd+                    Nothing -> return ()+                    Just pos -> do+                      aids <- filterHear pos as+                      if null aids && not profound+                      then return ()+                      else do+                        distance <- if null aids+                                    then return Nothing+                                    else leaderDistance pos+                        sendUpdate fid $ UpdHearFid fid distance $ HearUpd cmd+                        mapM_ drainCalmOnce aids+                SfxAtomic cmd -> do+                  mhear <- hearSfxAtomic cmd+                  case mhear of+                    Nothing -> return ()+                    Just (hearMsg, profound, pos) -> do+                      aids <- filterHear pos as+                      if null aids && not profound+                      then return ()+                      else do+                        distance <- if null aids+                                    then return Nothing+                                    else leaderDistance pos+                        sendUpdate fid $ UpdHearFid fid distance hearMsg+                        mapM_ drainCalmOnce aids+      -- We assume players perceive perception change before the action,+      -- so the action is perceived in the new perception,+      -- even though the new perception depends on the action's outcome+      -- (e.g., new actor created).+      send fid = do+        let perFid = sperFidOld EM.! fid+        if seenAtomicCli knowEvents fid perFid ps+        then sendAtomic fid atomic+        else breakSend fid perFid+  -- Factions that are eliminated by the command are processed as well,+  -- because they are not deleted from @sfactionD@.+  factionD <- getsState sfactionD+  mapM_ send $ EM.keys factionD++cmdItemsFromIids :: [ItemId] -> State -> State -> [UpdAtomic]+cmdItemsFromIids iids sClient s =+  let iidsUnknown = filter (\iid -> EM.notMember iid $ sitemD sClient) iids+      items = map (\iid -> (iid, sitemD s EM.! iid)) iidsUnknown+  in [UpdRegisterItems items | not $ null items]++-- | Messages for some unseen atomic commands.+hearUpdAtomic :: MonadStateRead m+              => UpdAtomic -> m (Bool, Maybe Point)+hearUpdAtomic cmd = do+  COps{coTileSpeedup} <- getsState scops+  case cmd of+    UpdDestroyActor _ body _ | not $ bproj body ->+      return (True, Just $ bpos body)+    UpdCreateItem True iid item _ (CActor aid cstore) -> do+      -- Kinetic damage implies the explosion is loud enough to cause noise.+      itemKind <- getsState $ getItemKindServer item+      discoAspect <- getsState sdiscoAspect+      let arItem = discoAspect EM.! iid+      if cstore /= COrgan+         || IA.checkFlag Ability.Blast arItem+            && Dice.supDice (IK.idamage itemKind) > 0 then do+        body <- getsState $ getActorBody aid+        return (True, Just $ bpos body)+      else return (False, Nothing)+    UpdTrajectory aid (Just (l, _)) Nothing | not (null l) -> do+      -- Non-blast projectile hits a non-walkable tile.+      b <- getsState $ getActorBody aid+      discoAspect <- getsState sdiscoAspect+      let arTrunk = discoAspect EM.! btrunk b+      return ( False, if not (bproj b) || IA.checkFlag Ability.Blast arTrunk+                      then Nothing+                      else Just $ bpos b )+    UpdAlterTile _ p _ toTile ->+      return (not $ Tile.isDoor coTileSpeedup toTile, Just p)+    UpdAlterExplorable{} -> return (True, Nothing)+    _ -> return (False, Nothing)++-- | Messages for some unseen sfx.+hearSfxAtomic :: MonadServer m+              => SfxAtomic -> m (Maybe (HearMsg, Bool, Point))+hearSfxAtomic cmd =+  case cmd of+    SfxStrike aid _ iid -> do+      -- Only the attacker position considered, for simplicity.+      b <- getsState $ getActorBody aid+      discoAspect <- getsState sdiscoAspect+      let arItem = discoAspect EM.! iid+      itemKindId <- getsState $ getIidKindIdServer iid+      -- Loud explosions cause enough noise, so ignoring particle hit spam.+      return $! if IA.checkFlag Ability.Blast arItem+                then Nothing+                else Just (HearStrike itemKindId, False, bpos b)+    SfxEffect _ aid _ (IK.Summon grp p) _ -> do+      b <- getsState $ getActorBody aid+      return $ Just (HearSummon (bproj b) grp p, False, bpos b)+    SfxEffect _ aid _ (IK.VerbMsg verb ending) _ -> do+      b <- getsState $ getActorBody aid+      discoAspect <- getsState sdiscoAspect+      let arTrunk = discoAspect EM.! btrunk b+          subject = "noises of someone that"+          phrase = makePhrase [MU.SubjectVerbSg subject (MU.Text verb)]+                   <> ending+      return $! if IA.checkFlag Ability.Unique arTrunk+                then Just (HearTaunt phrase, True, bpos b)+                else Nothing+    SfxCollideTile _ p ->+      return $ Just (HearCollideTile, False, p)+    SfxTaunt voluntary aid -> do+      b <- getsState $ getActorBody aid+      (subject, verb) <- displayTaunt voluntary rndToAction aid+      discoAspect <- getsState sdiscoAspect+      let arTrunk = discoAspect EM.! btrunk b+          unique = if IA.checkFlag Ability.Unique arTrunk then "big" else ""+          phrase = subject <+> unique <+> verb <> "."+      return $ Just (HearTaunt phrase, True, bpos b)  -- intentional+    _ -> return Nothing++filterHear :: MonadStateRead m => Point -> [(ActorId, Actor)] -> m [ActorId]+filterHear pos as = do+  let actorHear (aid, body) = do+        -- Actors hear as if they were leaders, for speed and to prevent+        -- micromanagement by switching leader to hear more.+        -- This is analogous to actors seeing as if they were leaders.+        actorMaxSk <- getsState $ getActorMaxSkills aid+        return $! Ability.getSk Ability.SkHearing actorMaxSk+                  >= chessDist pos (bpos body)+  map fst <$> filterM actorHear as++sendPer :: (MonadServerAtomic m, MonadServerComm m)+        => FactionId -> LevelId -> Perception -> Perception -> Perception+        -> m ()+sendPer fid lid outPer inPer perNew = do+  knowEvents <- getsServer $ sknowEvents . soptions+  unless knowEvents $ do  -- inconsistencies would quickly manifest+    sendUpdNoState fid $ UpdPerception lid outPer inPer+    sClient <- getsServer $ (EM.! fid) . sclientStates+    let forget = atomicForget fid lid outPer sClient+    remember <- getsState $ atomicRemember lid inPer sClient+    let seenNew = seenAtomicCli False fid (EM.singleton lid perNew)+        onLevel UpdRegisterItems{} = True+        onLevel UpdLoseStashFaction{} = True+        onLevel _ = False+    psRem <- mapM posUpdAtomic $ filter (not . onLevel) remember+    -- Verify that we remember the currently seen things.+    let !_A = assert (allB seenNew psRem) ()+    mapM_ (sendUpdateCheck fid) forget+    mapM_ (sendUpdate fid) remember++-- Remembered items, map tiles, smells and stashes are not wiped out+-- when they get out of FOV. Clients remember them. Only actors are forgotten.+atomicForget :: FactionId -> LevelId -> Perception -> State+             -> [UpdAtomic]+atomicForget side lid outPer sClient =+  -- Wipe out actors that just became invisible due to changed FOV.+  let outFov = totalVisible outPer+      fActor (aid, b) =+        -- We forget only currently invisible actors. Actors can be outside+        -- perception, but still visible, if they belong to our faction,+        -- e.g., if they teleport to outside of current perception+        -- or if they have disabled senses.+        UpdLoseActor aid b+          -- this command always succeeds, the actor can be always removed,+          -- because the actor is taken from the state+      outPrioBig = mapMaybe (\p -> posToBigAssoc p lid sClient)+                   $ ES.elems outFov+      outPrioProj = concatMap (\p -> posToProjAssocs p lid sClient)+                    $ ES.elems outFov+  in map fActor $ filter ((/= side) . bfid . snd) outPrioBig ++ outPrioProj++-- The second argument are the points newly in FOV.+atomicRemember :: LevelId -> Perception -> State -> State -> [UpdAtomic]+{-# INLINE atomicRemember #-}+atomicRemember lid inPer sClient s =+  let COps{cotile, coTileSpeedup} = scops s+      locateStash ((fidClient, factClient), (fid, fact)) =+        assert (fidClient == fid)+        $ case (gstash factClient, gstash fact) of+            (Just (lidStash, pos), Nothing)+              | lidStash == lid && pos `ES.member` totalVisible inPer ->+                [UpdLoseStashFaction False fid lid pos]+            (Nothing, Just (lidStash, pos))+              | lidStash == lid && pos `ES.member` totalVisible inPer ->+                [UpdSpotStashFaction True fid lid pos]+            (Just (lidStash1, pos1), Just (lidStash2, pos2))+              | gstash factClient /= gstash fact ->+                if | lidStash2 == lid && pos2 `ES.member` totalVisible inPer ->+                     [ UpdLoseStashFaction False fid lidStash1 pos1+                     , UpdSpotStashFaction True fid lid pos2 ]+                   | lidStash1 == lid && pos1 `ES.member` totalVisible inPer ->+                     [UpdLoseStashFaction False fid lid pos1]+                   | otherwise -> []+            _ -> []+      atomicStash = concatMap locateStash $ zip (EM.assocs $ sfactionD sClient)+                                                (EM.assocs $ sfactionD s)+      inFov = ES.elems $ totalVisible inPer+      lvl = sdungeon s EM.! lid+      -- Wipe out remembered items on tiles that now came into view+      -- and spot items on these tiles. Optimized away, when items match.+      lvlClient = sdungeon sClient EM.! lid+      inContainer allow fc bagEM bagEMClient =+        let f p = case (EM.lookup p bagEM, EM.lookup p bagEMClient) of+              (Nothing, Nothing) -> []  -- most common, no items ever+              (Just bag, Nothing) ->  -- common, client unaware+                cmdItemsFromIids (EM.keys bag) sClient s+                ++ [UpdSpotItemBag True (fc lid p) bag | allow p]+              (Nothing, Just bagClient) ->  -- uncommon, all items vanished+                -- We don't check @allow@, because client sees items there,+                -- so we assume he's aware of the tile enough to notice.+                [UpdLoseItemBag True (fc lid p) bagClient]+              (Just bag, Just bagClient) ->+                -- We don't check @allow@, because client sees items there,+                -- so we assume he's aware of the tile enough to see new items.+                if bag == bagClient+                then []  -- common, nothing has changed, so optimized+                else -- uncommon, surprise; because it's rare, we send+                     -- whole bags and don't optimize by sending only delta+                     cmdItemsFromIids (EM.keys bag) sClient s+                     ++ [ UpdLoseItemBag True (fc lid p) bagClient+                        , UpdSpotItemBag True (fc lid p) bag ]+        in concatMap f inFov+      inFloor = inContainer (const True) CFloor (lfloor lvl) (lfloor lvlClient)+      -- Check that client may be shown embedded items, assuming he's not seeing+      -- any at this position so far. If he's not shown now, the items will be+      -- revealed via searching the tile later on.+      -- This check is essential to prevent embedded items from leaking+      -- tile identity.+      allowEmbed p = not (Tile.isHideAs coTileSpeedup $ lvl `at` p)+                     || lvl `at` p == lvlClient `at` p+      inEmbed = inContainer allowEmbed CEmbed (lembed lvl) (lembed lvlClient)+      -- Spot tiles.+      atomicTile =+        -- We ignore the server resending us hidden versions of the tiles+        -- (or resending us the same data we already got).+        -- If the tiles are changed to other variants of the hidden tile,+        -- we can still verify by searching.+        let f p (loses1, spots1, entries1) =+              let t = lvl `at` p+                  tHidden = fromMaybe t $ Tile.hideAs cotile t+                  tClient = lvlClient `at` p+                  entries2 = case EM.lookup p $ lentry lvl of+                    Nothing -> entries1+                    Just entry2 -> case EM.lookup p $ lentry lvlClient of+                      Nothing -> (p, entry2) : entries1+                      Just entry3 -> assert (entry3 == entry2) entries1+                        -- avoid resending entries if client previously saw+                        -- another not hidden tile at that position+              in if tClient `elem` [t, tHidden]+                 then (loses1, spots1, entries1)+                 else ( if isUknownSpace tClient+                        then loses1+                        else (p, tClient) : loses1+                      , (p, tHidden) : spots1  -- send the hidden version+                      , if tHidden == t then entries2 else entries1)+            (loses, spots, entries) = foldr f ([], [], []) inFov+        in [UpdLoseTile lid loses | not $ null loses]+           ++ [UpdSpotTile lid spots | not $ null spots]+           ++ [UpdSpotEntry lid entries | not $ null entries]+      -- Wipe out remembered smell on tiles that now came into smell Fov.+      -- Smell radius is small, so we can just wipe and send all.+      -- TODO: only send smell younger than ltime (states get out of sync)+      -- or remove older smell elsewhere in the code each turn (expensive).+      -- For now clients act as if this was the case, not peeking into old.+      inSmellFov = ES.elems $ totalSmelled inPer+      inSm = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvlClient)) inSmellFov+      inSmell = [UpdLoseSmell lid inSm | not $ null inSm]+      -- Spot smells.+      inSm2 = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvl)) inSmellFov+      atomicSmell = [UpdSpotSmell lid inSm2 | not $ null inSm2]+      -- Actors come last to report the environment they land on.+      inAssocs = concatMap (\p -> posToAidAssocs p lid s) inFov+      -- Here, the actor may be already visible, e.g., when teleporting,+      -- so the exception is caught in @sendUpdate@ above.+      fActor (aid, b) = cmdItemsFromIids (getCarriedIidsAndTrunk b) sClient s+                        ++ [UpdSpotActor aid b]+      inActor = concatMap fActor inAssocs+  in atomicStash ++ inActor ++ inSmell ++ atomicSmell ++ inFloor+     ++ atomicTile ++ inEmbed
+ engine-src/Game/LambdaHack/Server/Commandline.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE ApplicativeDo #-}+-- | Parsing of commandline arguments.+module Game.LambdaHack.Server.Commandline+  ( serverOptionsPI+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , serverOptionsP+      -- other internal operations too numerous and changing, so not listed+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude+-- Cabal+import qualified Paths_LambdaHack as Self (version)++import qualified Data.Text as T+import           Data.Version+import           Options.Applicative+import qualified System.Random.SplitMix32 as SM++-- Dependence on ClientOptions is an anomaly. Instead, probably the raw+-- remaining commandline should be passed and parsed by the client to extract+-- client and ui options from and singnal an error if anything was left.++import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Definition.Defs+import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal+import           Game.LambdaHack.Server.ServerOptions++-- | Parser for server options from commandline arguments.+serverOptionsPI :: ParserInfo ServerOptions+serverOptionsPI = info (serverOptionsP <**> helper <**> version)+                  $ fullDesc+                    <> progDesc "Configure debug options here, gameplay options in configuration file."++version :: Parser (a -> a)+version = infoOption (showVersion Self.version)+  (long "version"+   <> help "Print engine version information")++serverOptionsP :: Parser ServerOptions+serverOptionsP = do+  ~(snewGameSer, scurChalSer)+                    <- serToChallenge <$> newGameP+  sfullscreenMode   <- fullscreenModeP+  knowMap           <- knowMapP+  knowEvents        <- knowEventsP+  knowItems         <- knowItemsP+  showItemSamples   <- showItemSamplesP+  sexposePlaces     <- exposePlacesP+  sexposeItems      <- exposeItemsP+  sexposeActors     <- exposeActorsP+  sniff             <- sniffP+  sallClear         <- allClearP+  sboostRandomItem  <- boostRandItemP+  sgameMode         <- gameModeP+  sautomateAll      <- automateAllP+  skeepAutomated    <- keepAutomatedP+  sstopAfterSeconds <- stopAfterSecsP+  sstopAfterFrames  <- stopAfterFramesP+  sstopAfterGameOver <- stopAfterGameOverP+  sprintEachScreen  <- printEachScreenP+  sbenchmark        <- benchmarkP+  sbenchMessages    <- benchMessagesP+  sdungeonRng       <- setDungeonRngP+  smainRng          <- setMainRngP+  sdumpInitRngs     <- dumpInitRngsP+  sdbgMsgCli        <- dbgMsgCliP+  sdbgMsgSer        <- dbgMsgSerP+  slogPriority      <- logPriorityP+  sassertExplored   <- assertExploredP+  schosenFontset    <- chosenFontsetP+  sallFontsScale    <- allFontsScaleP+  smaxFps           <- maxFpsP+  sdisableAutoYes   <- disableAutoYesP+  snoAnim           <- noAnimP+  ssavePrefixSer    <- savePrefixP+  sfrontendANSI     <- frontendANSIP+  sfrontendTeletype <- frontendTeletypeP+  sfrontendNull     <- frontendNullP+  sfrontendLazy     <- frontendLazyP++  pure ServerOptions+    {+      sclientOptions = ClientOptions+        { sfonts         = []  -- comes only from config file+        , sfontsets      = []  -- comes only from config file+        , stitle         = Nothing+        , snewGameCli    = snewGameSer+        , ssavePrefixCli = ssavePrefixSer+        , ..+        }+    , sknowMap = knowMap || knowEvents || knowItems+    , sknowEvents = knowEvents || knowItems+    , sknowItems = knowItems+    , sshowItemSamples = not (knowEvents || knowItems) && showItemSamples+    , ..+    }+ where+   serToChallenge :: Maybe Int -> (Bool, Challenge)+   serToChallenge Nothing      = (False, defaultChallenge)+   serToChallenge (Just cdiff) = (True, defaultChallenge {cdiff})++knowMapP :: Parser Bool+knowMapP =+  switch (  long "knowMap"+         <> help "Reveal map for all clients in the next game" )++knowEventsP :: Parser Bool+knowEventsP =+  switch (  long "knowEvents"+         <> help "Show all events in the next game (implies --knowMap)" )++knowItemsP :: Parser Bool+knowItemsP =+  switch (  long "knowItems"+         <> help "Auto-identify all items in the next game (implies --knowEvents)" )++exposePlacesP :: Parser Bool+exposePlacesP =+  switch (  long "exposePlaces"+         <> help "Expose all possible places in the next game" )++exposeItemsP :: Parser Bool+exposeItemsP =+  switch (  long "exposeItems"+         <> help "Expose all possible items in the next game" )++exposeActorsP :: Parser Bool+exposeActorsP =+  switch (  long "exposeActors"+         <> help "Expose all killable actors in the next game" )++showItemSamplesP :: Parser Bool+showItemSamplesP =+  switch (  long "showItemSamples"+         <> help "At game over show samples of all items (--knowEvents disables this)" )++sniffP :: Parser Bool+sniffP =+  switch (  long "sniff"+         <> help "Monitor all trafic between server and clients" )++allClearP :: Parser Bool+allClearP =+  switch (  long "allClear"+         <> help "Let all map tiles be translucent" )++boostRandItemP :: Parser Bool+boostRandItemP =+  switch (  long "boostRandomItem"+         <> help "Pick a random item and make it very common" )++gameModeP :: Parser (Maybe (GroupName ModeKind))+gameModeP = optional $ toGameMode <$>+  option nonEmptyStr+         (  long "gameMode"+            <> metavar "MODE"+            <> help "Start next game in the scenario indicated by MODE" )+ where+  -- This ignores all but the first word of a game mode name+  -- and assumes the fist word is present among its frequencies.+  toGameMode :: String -> GroupName ModeKind+  toGameMode = DefsInternal.GroupName . head . T.words . T.pack+  nonEmptyStr :: ReadM String+  nonEmptyStr = eitherReader $ \case+    "" -> Left "name of game mode cannot be empty"+    ns -> Right ns++automateAllP :: Parser Bool+automateAllP =+  switch (  long "automateAll"+         <> help "Give control of all UI teams to computer" )++keepAutomatedP :: Parser Bool+keepAutomatedP =+  switch (  long "keepAutomated"+         <> help "Keep factions automated after game over" )++newGameP :: Parser (Maybe Int)+newGameP = optional $ max 1 . min difficultyBound <$>+  option auto (  long "newGame"+              <> help "Start a new game, overwriting the save file and often forgetting history, with difficulty for all UI players set to N"+              <> metavar "N" )++fullscreenModeP :: Parser (Maybe FullscreenMode)+fullscreenModeP = optional $+  option auto (  long "fullscreenMode"+              <> short 'f'+              <> metavar "MODE"+              <> help "Display in MODE, one of NotFullscreen (default), BigBorderlessWindow (preferred), ModeChange" )++stopAfterSecsP :: Parser (Maybe Int)+stopAfterSecsP = optional $ max 0 <$>+  option auto (  long "stopAfterSeconds"+              <> help "Exit game session after around N seconds"+              <> metavar "N" )++stopAfterFramesP :: Parser (Maybe Int)+stopAfterFramesP = optional $ max 0 <$>+  option auto (  long "stopAfterFrames"+              <> help "Exit game session after around N frames"+              <> metavar "N" )++stopAfterGameOverP :: Parser Bool+stopAfterGameOverP =+  switch (  long "stopAfterGameOver"+         <> help "Exit the application after game over" )++printEachScreenP :: Parser Bool+printEachScreenP =+  switch (  long "printEachScreen"+         <> help "Take a screenshot of each rendered distinct frame (SDL only)" )++benchmarkP :: Parser Bool+benchmarkP =+  switch (  long "benchmark"+         <> help "Restrict file IO, print timing stats" )++benchMessagesP :: Parser Bool+benchMessagesP =+  switch (  long "benchMessages"+         <> help "Display messages in realistic was under AI control (for benchmarks)" )++setDungeonRngP :: Parser (Maybe SM.SMGen)+setDungeonRngP = optional $+  option auto (  long "setDungeonRng"+              <> metavar "RNG_SEED"+              <> help "Set dungeon generation RNG seed to string RNG_SEED" )++setMainRngP :: Parser (Maybe SM.SMGen)+setMainRngP = optional $+  option auto (  long "setMainRng"+              <> metavar "RNG_SEED"+              <> help "Set the main game RNG seed to string RNG_SEED" )++dumpInitRngsP :: Parser Bool+dumpInitRngsP =+  switch (  long "dumpInitRngs"+         <> help "Dump the RNG seeds used to initialize the game" )++dbgMsgCliP :: Parser Bool+dbgMsgCliP =+  switch (  long "dbgMsgCli"+         <> help "Emit extra internal client debug messages" )++dbgMsgSerP :: Parser Bool+dbgMsgSerP =+  switch (  long "dbgMsgSer"+         <> help "Emit extra internal server debug messages" )++logPriorityP :: Parser (Maybe Int)+logPriorityP = optional $+  option (auto >>= verifyLogPriority) $+       long "logPriority"+    <> showDefault+    <> value 5+    <> metavar "N"+    <> help ( "Log only messages of priority at least N, where 1 (all) is "+           ++ "the lowest and 5 logs errors only; use value 0 for testing on "+           ++ "CIs without graphics access; setting priority to 0 causes "+           ++ "SDL frontend to init and quit at once" )+  where+    verifyLogPriority n =+      if n >= 0 && n <= 5+      then return n+      else readerError "N has to be 0 or a positive integer not larger than 5"++assertExploredP :: Parser (Maybe Int)+assertExploredP = optional $ max 1 <$>+  option auto (  long "assertExplored"+              <> help "Check that when the session ends, the indicated level has been explored"+              <> metavar "N" )++chosenFontsetP :: Parser (Maybe Text)+chosenFontsetP = optional $ T.pack <$>+  strOption (  long "fontset"+            <> metavar "FONTSET_ID"+            <> help "Render UI using the given fontset from config file" )++allFontsScaleP :: Parser (Maybe Double)+allFontsScaleP = optional $ max 0 <$>+  option auto (  long "allFontsScale"+              <> metavar "D"+              <> help "Scale all fonts by D, resizing the whole UI" )++maxFpsP :: Parser (Maybe Double)+maxFpsP = optional $ max 0 <$>+  option auto (  long "maxFps"+              <> metavar "D"+              <> help "Display at most D frames per second" )++disableAutoYesP :: Parser Bool+disableAutoYesP =+  switch (  long "disableAutoYes"+         <> help "Never auto-answer prompts, not even when UI faction is automated" )++noAnimP :: Parser (Maybe Bool)+noAnimP =+  flag Nothing (Just True)+       (  long "noAnim"+       <> help "Don't show any animations" )++savePrefixP :: Parser String+savePrefixP =+  strOption (  long "savePrefix"+            <> metavar "PREFIX"+            <> showDefault+            <> value ""+            <> help "Prepend PREFIX to all savefile names" )++frontendANSIP :: Parser Bool+frontendANSIP =+  switch (  long "frontendANSI"+         <> help "Use the ANSI terminal frontend (best for screen readers)" )++frontendTeletypeP :: Parser Bool+frontendTeletypeP =+  switch (  long "frontendTeletype"+         <> help "Use the line terminal frontend (for tests)" )++frontendNullP :: Parser Bool+frontendNullP =+  switch (  long "frontendNull"+         <> help "Use frontend with no display (for benchmarks)" )++frontendLazyP :: Parser Bool+frontendLazyP =+  switch (  long "frontendLazy"+         <> help "Use frontend that not even computes frames (for benchmarks)" )
+ engine-src/Game/LambdaHack/Server/CommonM.hs view
@@ -0,0 +1,864 @@+{-# LANGUAGE TupleSections #-}+-- | Server operations common to many modules.+module Game.LambdaHack.Server.CommonM+  ( revealAll, generalMoveItem, deduceQuits+  , writeSaveAll, verifyCaches, deduceKilled, electLeader, setFreshLeader+  , updatePer, projectFail, addActorFromGroup, registerActor+  , discoverIfMinorEffects, pickWeaponServer, currentSkillsServer, allGroupItems+  , addCondition, removeConditionSingle, addSleep, removeSleepSingle+  , addKillToAnalytics+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , revealItems, revealPerceptionLid, containerMoveItem, quitF, keepArenaFact+  , anyActorsAlive, updatePerFromNew, recomputeCachePer+  , projectBla, addProjectile, addNonProjectile, addActorIid+  , getCacheLucid, getCacheTotal+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.IntMap.Strict as IM+import           Data.Ratio++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Analytics+import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.ClientOptions+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.CaveKind as CK+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal+import           Game.LambdaHack.Server.Fov+import           Game.LambdaHack.Server.ItemM+import           Game.LambdaHack.Server.ItemRev+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++revealItems :: MonadServerAtomic m => FactionId -> m ()+revealItems fid = do+  COps{coitem} <- getsState scops+  ServerOptions{sclientOptions} <- getsServer soptions+  discoAspect <- getsState sdiscoAspect+  let keptSecret kind ar = IA.isHumanTrinket kind+                           || IA.checkFlag Ability.MetaGame ar+      discover aid store iid _ = do+        itemKindId <- getsState $ getIidKindIdServer iid+        let arItem = discoAspect EM.! iid+            c = CActor aid store+            itemKind = okind coitem itemKindId+        unless (keptSecret itemKind arItem) $  -- a hack+          execUpdAtomic $ UpdDiscover c iid itemKindId arItem+      f (aid, b) =+        -- CStash is IDed for each actor of each faction, which is fine,+        -- even though it may introduce a slight lag at gameover.+        join $ getsState $ mapActorItems_ (discover aid) b+  -- Don't ID projectiles, their items are not really owned by the party.+  aids <- getsState $ fidActorNotProjGlobalAssocs fid+  mapM_ f aids+  dungeon <- getsState sdungeon+  let minLid = fst $ minimumBy (comparing (ldepth . snd))+                   $ EM.assocs dungeon+      discoverSample iid = do+        itemKindId <- getsState $ getIidKindIdServer iid+        let arItem = discoAspect EM.! iid+            cdummy = CTrunk fid minLid originPoint+            itemKind = okind coitem itemKindId+        -- Due to @cdummy@, the met and unmet secret things will appear+        -- at gameover among actors in the debug mode. Tough luck.+        execUpdAtomic $ if keptSecret itemKind arItem+                        then UpdSpotItem False iid quantSingle cdummy+                        else UpdDiscover cdummy iid itemKindId arItem+  generationAn <- getsServer sgenerationAn+  getKindId <- getsState $ flip getIidKindIdServer+  let kindsEqual iid iid2 = getKindId iid == getKindId iid2 && iid /= iid2+      nonDupSample em iid 0 = not $ any (kindsEqual iid) $ EM.keys em+      nonDupSample _ _ _ = True+      nonDupGen = EM.map (\em -> EM.filterWithKey (nonDupSample em) em)+                         generationAn+  -- Remove samples that are supplanted by real items.+  -- If there are mutliple UI factions, the second run will be vacuus,+  -- but it's important to do that before the first try to identify things+  -- to prevent spam from identifying samples that are not needed.+  modifyServer $ \ser -> ser {sgenerationAn = nonDupGen}+  when (sexposeActors sclientOptions) $+    -- Few, if any, need ID, but we can't rule out unusual content.+    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! STrunk+  when (sexposeItems sclientOptions) $ do+    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SItem+    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SEmbed+    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SOrgan+    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SCondition+    mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SBlast++revealAll :: MonadServerAtomic m => FactionId -> m ()+revealAll fid = do+  revealItems fid+  execUpdAtomic $ UpdMuteMessages fid True+  dungeon <- getsState sdungeon+  -- Perception needs to be sent explicitly, because normal management+  -- assumes an action must happen on a level to invalidate and regenerate+  -- perception on the level (and actors must survive!).+  -- Also, we'd rather hack here and in `verifyCaches` that complicate+  -- the already complex perception creation and caching code.+  mapM_ (revealPerceptionLid fid) $ EM.assocs dungeon+  execUpdAtomic $ UpdMuteMessages fid False++revealPerceptionLid :: MonadServerAtomic m+                    => FactionId -> (LevelId, Level) -> m ()+revealPerceptionLid fid (lid, lvl) = do+  let (x0, y0, x1, y1) = fromArea $ larea lvl+      fullSet = ES.fromDistinctAscList [ Point x y+                                       | y <- [y0 .. y1]+                                       , x <- [x0 .. x1] ]+      perNew = Perception+        { psight = PerVisible fullSet+        , psmell = PerSmelled ES.empty  -- don't obscure+        }+  updatePerFromNew fid lid perNew++-- | Generate the atomic updates that jointly perform a given item move.+generalMoveItem :: MonadStateRead m+                => Bool -> ItemId -> Int -> Container -> Container+                -> m [UpdAtomic]+generalMoveItem _ iid k (CActor aid1 cstore1) c2@(CActor aid2 cstore2)+  | aid1 == aid2 = do+    moveStash <- moveStashIfNeeded c2+    return $! moveStash ++ [UpdMoveItem iid k aid1 cstore1 cstore2]+generalMoveItem verbose iid k c1 c2 = containerMoveItem verbose iid k c1 c2++containerMoveItem :: MonadStateRead m+                  => Bool -> ItemId -> Int -> Container -> Container+                  -> m [UpdAtomic]+containerMoveItem verbose iid k c1 c2 = do+  bag <- getsState $ getContainerBag c1+  case iid `EM.lookup` bag of+    Nothing -> error $ "" `showFailure` (iid, k, c1, c2)+    Just (_, it) -> do+      moveStash <- moveStashIfNeeded c2+      return $ [UpdLoseItem verbose iid (k, take k it) c1]+               ++ moveStash+               ++ [UpdSpotItem verbose iid (k, take k it) c2]++quitF :: MonadServerAtomic m => Status -> FactionId -> m ()+quitF status fid = do+  fact <- getsState $ (EM.! fid) . sfactionD+  let oldSt = gquit fact+  -- Note that it's the _old_ status that we check here.+  case stOutcome <$> oldSt of+    Just Killed -> return ()    -- Do not overwrite in case+    Just Defeated -> return ()  -- many things happen in 1 turn.+    Just Conquer -> return ()+    Just Escape -> return ()+    _ -> do+      let !_A = assert (stOutcome status `notElem` [Camping, Restart]+                        `blame` "Camping and Restart are handled separately"+                        `swith` (stOutcome <$> oldSt, status, fid)) ()+      -- This runs regardless of the _new_ status.+      manalytics <-+        if fhasUI $ gkind fact then do+          keepAutomated <- getsServer $ skeepAutomated . soptions+          -- Try to remove AI control of the UI faction, to show gameover info.+          when (gunderAI fact && not keepAutomated) $+            execUpdAtomic $ UpdAutoFaction fid False+          revealAll fid+          -- Likely, by this time UI faction is no longer AI-controlled,+          -- so the score will get registered.+          registerScore status fid+          factionAn <- getsServer sfactionAn+          generationAn <- getsServer sgenerationAn+          return $ Just (factionAn, generationAn)+        else return Nothing+      execUpdAtomic $ UpdQuitFaction fid oldSt (Just status) manalytics+      modifyServer $ \ser -> ser {sbreakLoop = True}  -- check game over++-- Send any UpdQuitFaction actions that can be deduced from factions'+-- current state.+deduceQuits :: MonadServerAtomic m => FactionId -> Status -> m ()+deduceQuits fid0 status@Status{stOutcome}+  | stOutcome `elem` [Defeated, Camping, Restart, Conquer] =+    error $ "no quitting to deduce" `showFailure` (fid0, status)+deduceQuits fid0 status = do+  fact0 <- getsState $ (EM.! fid0) . sfactionD+  let factHasUI = fhasUI . gkind+      quitFaction (stOutcome, (fid, _)) = quitF status{stOutcome} fid+      mapQuitF outfids = do+        let (withUI, withoutUI) =+              partition (factHasUI . snd . snd)+                        ((stOutcome status, (fid0, fact0)) : outfids)+        mapM_ quitFaction (withoutUI ++ withUI)+      inGameOutcome (fid, fact) = do+        let mout | fid == fid0 = Just $ stOutcome status+                 | otherwise = stOutcome <$> gquit fact+        case mout of+          Just Killed -> False+          Just Defeated -> False+          Just Restart -> False  -- effectively, commits suicide+          _ -> True+  factionD <- getsState sfactionD+  let assocsInGame = filter inGameOutcome $ EM.assocs factionD+      assocsKeepArena = filter (keepArenaFact . snd) assocsInGame+      assocsUI = filter (factHasUI . snd) assocsInGame+      nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame+      worldPeace =+        all (\(fid1, _) -> all (\(fid2, fact2) -> not $ isFoe fid2 fact2 fid1)+                           nonHorrorAIG)+        nonHorrorAIG+      othersInGame = filter ((/= fid0) . fst) assocsInGame+  if | null assocsUI ->+       -- Only non-UI players left in the game and they all win.+       mapQuitF $ zip (repeat Conquer) othersInGame+     | null assocsKeepArena ->+       -- Only leaderless and spawners remain (the latter may sometimes+       -- have no leader, just as the former), so they win,+       -- or we could get stuck in a state with no active arena+       -- and so no spawns.+       mapQuitF $ zip (repeat Conquer) othersInGame+     | worldPeace ->+       -- Nobody is at war any more, so all win (e.g., horrors, but never mind).+       mapQuitF $ zip (repeat Conquer) othersInGame+     | stOutcome status == Escape -> do+       -- Otherwise, in a game with many warring teams alive,+       -- only complete Victory matters, until enough of them die.+       let (victors, losers) =+             partition (\(fi, _) -> isFriend fid0 fact0 fi) othersInGame+       mapQuitF $ zip (repeat Escape) victors ++ zip (repeat Defeated) losers+     | otherwise -> quitF status fid0++-- | Save game on server and all clients.+writeSaveAll :: MonadServerAtomic m => Bool -> Bool -> m ()+writeSaveAll uiRequested evenForNoConfirmGames = do+  bench <- getsServer $ sbenchmark . sclientOptions . soptions+  noConfirmsGame <- isNoConfirmsGame+  when (uiRequested+        || not bench && (not noConfirmsGame || evenForNoConfirmGames)) $ do+    execUpdAtomic UpdWriteSave+    saveServer+#ifdef WITH_EXPENSIVE_ASSERTIONS+    -- This check is sometimes repeated in @gameExit@, but we don't care about+    -- speed of shutdown and even more so in WITH_EXPENSIVE_ASSERTIONS mode.+    verifyCaches+#endif++verifyCaches :: MonadServer m => m ()+verifyCaches = do+  sperCacheFid <- getsServer sperCacheFid+  sperValidFid <- getsServer sperValidFid+  sactorMaxSkills2 <- getsState sactorMaxSkills+  sfovLucidLid <- getsServer sfovLucidLid+  sfovClearLid <- getsServer sfovClearLid+  sfovLitLid <- getsServer sfovLitLid+  sperFid <- getsServer sperFid+  actorMaxSkills <- getsState maxSkillsInDungeon+  ( fovLitLid, fovClearLid, fovLucidLid+   ,perValidFid, perCacheFid, perFid ) <- getsState perFidInDungeon+  rngs <- getsServer srngs  -- initial display may scroll off terminal memory+  factionD <- getsState sfactionD+  -- Perception off UI faction at game over is illegal (revealed to the player+  -- in 'revealAll'), which is fine, because it's never used.+  -- Don't verify perception in such cases. All the caches from which+  -- legal perception would be created at that point are legal and verified,+  -- which is almost as tight.+  let gameOverUI fact = fhasUI (gkind fact)+                        && maybe False ((/= Camping) . stOutcome) (gquit fact)+      isGameOverUI = any gameOverUI $ EM.elems factionD+      !_A7 = assert (sfovLitLid == fovLitLid+                     `blame` "wrong accumulated sfovLitLid"+                     `swith` (sfovLitLid, fovLitLid, rngs)) ()+      !_A6 = assert (sfovClearLid == fovClearLid+                     `blame` "wrong accumulated sfovClearLid"+                     `swith` (sfovClearLid, fovClearLid, rngs)) ()+      !_A5 = assert (sactorMaxSkills2 == actorMaxSkills+                     `blame` "wrong accumulated sactorMaxSkills"+                     `swith` (sactorMaxSkills2, actorMaxSkills, rngs)) ()+      !_A4 = assert (sfovLucidLid == fovLucidLid+                     `blame` "wrong accumulated sfovLucidLid"+                     `swith` (sfovLucidLid, fovLucidLid, rngs)) ()+      !_A3 = assert (sperValidFid == perValidFid+                     `blame` "wrong accumulated sperValidFid"+                     `swith` (sperValidFid, perValidFid, rngs)) ()+      !_A2 = assert (sperCacheFid == perCacheFid+                     `blame` "wrong accumulated sperCacheFid"+                     `swith` (sperCacheFid, perCacheFid, rngs)) ()+      !_A1 = assert (isGameOverUI || sperFid == perFid+                     `blame` "wrong accumulated perception"+                     `swith` (sperFid, perFid, rngs)) ()+  return ()++-- | Tell whether a faction that we know is still in game, keeps arena.+-- Keeping arena means, if the faction is still in game,+-- it always has a leader in the dungeon somewhere.+-- So, leaderless factions and spawner factions do not keep an arena,+-- even though the latter usually has a leader for most of the game.+keepArenaFact :: Faction -> Bool+keepArenaFact fact = fhasPointman (gkind fact) && fneverEmpty (gkind fact)++-- We assume the actor in the second argument has HP <= 0 or is going to be+-- dominated right now. Even if the actor is to be dominated,+-- @bfid@ of the actor body is still the old faction.+deduceKilled :: MonadServerAtomic m => ActorId -> m ()+deduceKilled aid = do+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  when (fneverEmpty $ gkind fact) $ do+    actorsAlive <- anyActorsAlive (bfid body) aid+    unless actorsAlive $+      deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing++anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool+anyActorsAlive fid aid = do+  as <- getsState $ fidActorNotProjGlobalAssocs fid+  -- We test HP here, in case more than one actor goes to 0 HP in the same turn.+  return $! any (\(aid2, b2) -> aid2 /= aid && bhp b2 > 0) as++electLeader :: MonadServerAtomic m => FactionId -> LevelId -> ActorId -> m ()+electLeader fid lid aidToReplace = do+  mleader <- getsState $ gleader . (EM.! fid) . sfactionD+  when (mleader == Just aidToReplace) $ do+    allOurs <- getsState $ fidActorNotProjGlobalAssocs fid  -- not only on level+    let -- Prefer actors on this level and with positive HP and not sleeping.+        -- Exclude @aidToReplace@, even if not dead (e.g., if being dominated).+        (positive, negative) = partition (\(_, b) -> bhp b > 0) allOurs+        (awake, sleeping) = partition (\(_, b) -> bwatch b /= WSleep) positive+    onThisLevel <- getsState $ fidActorRegularAssocs fid lid+    let candidates = filter (\(_, b) -> bwatch b /= WSleep) onThisLevel+                     ++ awake ++ sleeping ++ negative+        mleaderNew = find (/= aidToReplace) $ map fst candidates+    execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew++setFreshLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()+setFreshLeader fid aid = do+  fact <- getsState $ (EM.! fid) . sfactionD+  when (fhasPointman (gkind fact)) $ do+    -- First update and send Perception so that the new leader+    -- may report his environment.+    b <- getsState $ getActorBody aid+    let !_A = assert (not $ bproj b) ()+    valid <- getsServer $ (EM.! blid b) . (EM.! fid) . sperValidFid+    unless valid $ updatePer fid (blid b)+    execUpdAtomic $ UpdLeadFaction fid (gleader fact) (Just aid)++updatePer :: MonadServerAtomic m => FactionId -> LevelId -> m ()+updatePer fid lid = do+  -- Performed in the State after action, e.g., with a new actor.+  perNew <- recomputeCachePer fid lid+  updatePerFromNew fid lid perNew++updatePerFromNew :: MonadServerAtomic m+                 => FactionId -> LevelId -> Perception -> m ()+updatePerFromNew fid lid perNew = do+  -- Even if nothing needed to be done, perception is now validated.+  modifyServer $ \ser ->+    ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser}+  sperFidOld <- getsServer sperFid+  let perOld = sperFidOld EM.! fid EM.! lid+      inPer = diffPer perNew perOld+      outPer = diffPer perOld perNew+  unless (nullPer outPer && nullPer inPer) $ do+    -- Perception is modified on the server and sent to the client+    -- together with all the revealed info.+    let fper = EM.adjust (EM.insert lid perNew) fid+    modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}+    execSendPer fid lid outPer inPer perNew++recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception+recomputeCachePer fid lid = do+  total <- getCacheTotal fid lid+  fovLucid <- getCacheLucid lid+  getsState $ perceptionFromPTotal fid lid fovLucid total++-- The missile item is removed from the store only if the projection+-- went into effect (no failure occured).+projectFail :: MonadServerAtomic m+            => ActorId    -- ^ actor causing the projection+            -> ActorId    -- ^ actor projecting the item (is on current level)+            -> Point      -- ^ starting position of the projectile;+                          --   usually, but not always, position of @origin@+            -> Point      -- ^ target position of the projectile+            -> Int        -- ^ digital line parameter+            -> Bool       -- ^ whether to start at the origin's position+            -> ItemId     -- ^ the item to be projected+            -> CStore     -- ^ which store the items comes from+            -> Bool       -- ^ whether the item is a blast+            -> m (Maybe ReqFailure)+projectFail propeller origin oxy tpxy eps center iid cstore blast = do+  COps{coTileSpeedup} <- getsState scops+  body <- getsState $ getActorBody origin+  let lid = blid body+  lvl <- getLevel lid+  case bresenhamsLineAlgorithm eps oxy tpxy of+    Nothing -> return $ Just ProjectAimOnself+    Just [] -> error $ "projecting from the edge of level"+                       `showFailure` (oxy, tpxy)+    Just (pos : restUnlimited) -> do+      bag <- getsState $ getBodyStoreBag body cstore+      case EM.lookup iid bag of+        Nothing -> return $ Just ProjectOutOfReach+        Just _kit -> do+          itemFull <- getsState $ itemToFull iid+          actorSk <- currentSkillsServer origin+          actorMaxSk <- getsState $ getActorMaxSkills origin+          let skill = Ability.getSk Ability.SkProject actorSk+              forced = blast || bproj body+              calmE = calmEnough body actorMaxSk+              legal = permittedProject forced skill calmE itemFull+              arItem = aspectRecordFull itemFull+          case legal of+            Left reqFail -> return $ Just reqFail+            Right _ -> do+              let lobable = IA.checkFlag Ability.Lobable arItem+                  rest = if lobable+                         then take (chessDist oxy tpxy - 1) restUnlimited+                         else restUnlimited+                  t = lvl `at` pos+              if | not $ Tile.isWalkable coTileSpeedup t ->+                   return $ Just ProjectBlockTerrain+                 | occupiedBigLvl pos lvl ->+                   if blast then do+                     -- Hit the blocking actor by starting the explosion+                     -- particle where the projectile landed, not a step away.+                     -- The same when the spot has the explosive embed,+                     -- regardless if it's walkable (@pos@ is, that's enough).+                     -- No problem even if there's a big actor where+                     -- the projectile starts, though it's wierd it may get+                     -- away unharmed sometimes.+                     projectBla propeller origin oxy (pos:rest)+                                iid cstore blast+                     return Nothing+                   else return $ Just ProjectBlockActor+                 | otherwise -> do+                   -- Make the explosion less regular and weaker at the edges.+                   if blast && center then+                     -- Start in the center, not around, even if the center+                     -- is a non-walkable tile with the exploding embed+                     -- or if a big actor is there.+                     projectBla propeller origin oxy (pos:rest)+                                iid cstore blast+                   else+                     projectBla propeller origin pos rest+                                iid cstore blast+                   return Nothing++projectBla :: MonadServerAtomic m+           => ActorId    -- ^ actor causing the projection+           -> ActorId    -- ^ actor projecting the item (is on current lvl)+           -> Point      -- ^ starting point of the projectile+           -> [Point]    -- ^ rest of the trajectory of the projectile+           -> ItemId     -- ^ the item to be projected+           -> CStore     -- ^ which store the items comes from+           -> Bool       -- ^ whether the item is a blast+           -> m ()+projectBla propeller origin pos rest iid cstore blast = do+  body <- getsState $ getActorBody origin+  let lid = blid body+  localTime <- getsState $ getLocalTime lid+  unless blast $ execSfxAtomic $ SfxProject origin iid+  bag <- getsState $ getBodyStoreBag body cstore+  ItemFull{itemKind} <- getsState $ itemToFull iid+  case iid `EM.lookup` bag of+    Nothing -> error $ "" `showFailure` (origin, pos, rest, iid, cstore)+    Just kit@(_, it) -> do+      let delay =+            if IK.iweight itemKind == 0+            then timeTurn  -- big delay at start, e.g., to easily read hologram+            else timeZero  -- avoid running into own projectiles+          btime = absoluteTimeAdd delay localTime+      addProjectile propeller pos rest iid kit lid (bfid body) btime+      let c = CActor origin cstore+      execUpdAtomic $ UpdLoseItem False iid (1, take 1 it) c++addActorFromGroup :: MonadServerAtomic m+                  => GroupName ItemKind -> FactionId -> Point -> LevelId -> Time+                  -> m (Maybe ActorId)+addActorFromGroup actorGroup fid pos lid time = do+  Level{ldepth} <- getLevel lid+  -- We bootstrap the actor by first creating the trunk of the actor's body+  -- that contains the fixed properties of all actors of that kind.+  freq <- prepareItemKind 0 ldepth [(actorGroup, 1)]+  m2 <- rollItemAspect freq ldepth+  case m2 of+    NoNewItem -> return Nothing+    NewItem _ itemKnown itemFull itemQuant -> do+      let itemFullKit = (itemFull, itemQuant)+      Just <$> registerActor False itemKnown itemFullKit fid pos lid time++registerActor :: MonadServerAtomic m+              => Bool -> ItemKnown -> ItemFullKit+              -> FactionId -> Point -> LevelId -> Time+              -> m ActorId+registerActor summoned (ItemKnown kindIx ar _) (itemFullRaw, kit)+              bfid pos lid time = do+  COps{cocave} <- getsState scops+  let container = CTrunk bfid lid pos+      jfid = Just bfid+      itemKnown = ItemKnown kindIx ar jfid+      itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}+  trunkId <- registerItem False (itemFull, kit) itemKnown container+  aid <- addNonProjectile summoned trunkId (itemFull, kit) bfid pos lid time+  fact <- getsState $ (EM.! bfid) . sfactionD+  actorMaxSk <- getsState $ getActorMaxSkills aid+  condAnyFoeAdj <- getsState $ anyFoeAdj aid+  Level{lkind} <- getLevel lid+  let cinitSleep = CK.cinitSleep $ okind cocave lkind+  when (cinitSleep /= CK.InitSleepBanned+        && canSleep actorMaxSk+        && not condAnyFoeAdj+        && not summoned+        && not (fhasGender (gkind fact))) $ do  -- heroes never start asleep+    -- A lot of actors will wake up at once anyway, so let most start sleeping.+    let sleepOdds = if prefersSleep actorMaxSk then 19%20 else 2%3+    sleeps <- rndToAction $ chance sleepOdds+    when (cinitSleep == CK.InitSleepAlways || sleeps) $ addSleep aid+  return aid++addProjectile :: MonadServerAtomic m+              => ActorId -> Point -> [Point] -> ItemId -> ItemQuant -> LevelId+              -> FactionId -> Time+              -> m ()+addProjectile propeller pos rest iid (_, it) lid fid time = do+  itemFull <- getsState $ itemToFull iid+  let arItem = aspectRecordFull itemFull+      IK.ThrowMod{IK.throwHP} = IA.aToThrow arItem+      (trajectory, (speed, _)) =+        IA.itemTrajectory arItem (itemKind itemFull) (pos : rest)+      -- Trunk is added to equipment, not to organs, because it's the+      -- projected item, so it's carried, not grown.+      tweakBody b = b { bhp = xM throwHP+                      , btrajectory = Just (trajectory, speed)+                      , beqp = EM.singleton iid (1, take 1 it) }+  aid <- addActorIid iid itemFull True fid pos lid tweakBody+  bp <- getsState $ getActorBody propeller+  -- If propeller is a projectile, it may produce other projectiles, e.g.,+  -- by exploding, so it's not voluntary, so others are to blame.+  -- However, we can't easily see whether a pushed non-projectile actor+  -- produced a projectile due to colliding or voluntarily, so we assign+  -- blame to him.+  originator <- if bproj bp+                then getsServer $ EM.findWithDefault propeller propeller+                                  . strajPushedBy+                else return propeller+  modifyServer $ \ser ->+    ser { strajTime = updateActorTime fid lid aid time $ strajTime ser+        , strajPushedBy = EM.insert aid originator $ strajPushedBy ser }++addNonProjectile :: MonadServerAtomic m+                 => Bool -> ItemId -> ItemFullKit -> FactionId -> Point+                 -> LevelId -> Time+                 -> m ActorId+addNonProjectile summoned trunkId (itemFull, kit) fid pos lid time = do+  let tweakBody b = b { borgan = EM.singleton trunkId kit+                      , bcalm = if summoned+                                then xM 5  -- a tiny buffer before domination+                                else bcalm b }+  aid <- addActorIid trunkId itemFull False fid pos lid tweakBody+  -- We assume actor is never born pushed.+  modifyServer $ \ser ->+    ser {sactorTime = updateActorTime fid lid aid time $ sactorTime ser}+  return aid++addActorIid :: MonadServerAtomic m+            => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId+            -> (Actor -> Actor)+            -> m ActorId+addActorIid trunkId ItemFull{itemBase, itemKind, itemDisco=ItemDiscoFull arItem}+            bproj fid pos lid tweakBody = do+  COps{coitem} <- getsState scops+  -- Initial HP and Calm is based only on trunk and ignores organs.+  let trunkMaxHP = max 2 $ IA.getSkill Ability.SkMaxHP arItem+      hp = xM trunkMaxHP `div` 2+      -- Slightly reduced starting Calm to auto-id items that refill Calm+      -- and to let animals do some initial exploration before going to sleep.+      -- Higher reduction would cause confusingly low sight range at game+      -- start and even inability to handle equipment.+      calm = xM (max 1 $ IA.getSkill Ability.SkMaxCalm arItem - 10)+  -- Create actor.+  factionD <- getsState sfactionD+  curChalSer <- getsServer $ scurChalSer . soptions+  let fact = factionD EM.! fid+      teamContinuityOurs = fteam (gkind fact)+  bnumberTeam <-+    if bproj then return Nothing else do+      stcounter <- getsServer stcounter+      let number = EM.findWithDefault 0 teamContinuityOurs stcounter+      modifyServer $ \ser -> ser {stcounter =+        EM.insert teamContinuityOurs (succ number) stcounter}+      return $ Just (number, teamContinuityOurs)+  let bnumber = fst <$> bnumberTeam+  -- If difficulty is below standard, HP is added to the UI factions,+  -- otherwise HP is added to their enemies.+  -- If no UI factions, their role is taken by the escapees (for testing).+  let diffBonusCoeff = difficultyCoeff $ cdiff curChalSer+      -- For most projectiles (exceptions are, e.g.,  maxHP boosting rings),+      -- SkMaxHP is zero, which means they drop after one hit regardless+      -- of extra bhp they have due to piercing. That is fine.+      -- If we want armoured missiles, that should not be done via piercing,+      -- but via SkMaxHP of the thrown items. Rings that are piercing+      -- by coincidence are harmless, too. However, piercing should not be+      -- added to missiles via SkMaxHP or equipping them would be beneficial+      -- in a hard to balance way (e.g., one bullet adds 10 SkMaxHP).+      boostFact = not bproj+                  && if diffBonusCoeff > 0+                     then any (fhasUI . gkind . snd)+                              (filter (\(fi, fa) -> isFriend fi fa fid)+                                      (EM.assocs factionD))+                     else any (fhasUI . gkind  . snd)+                              (filter (\(fi, fa) -> isFoe fi fa fid)+                                      (EM.assocs factionD))+      finalHP | boostFact = min (xM 899)  -- no more than UI can stand+                                (hp * 2 ^ abs diffBonusCoeff)+              | otherwise = hp+      -- Prevent too high max HP resulting in panic when low HP/max HP ratio.+      maxHP = min (finalHP + xM 100) (2 * finalHP)+      bonusHP = fromEnum (maxHP `div` oneM) - trunkMaxHP+      healthOrgans = [(Just bonusHP, (IK.S_BONUS_HP, COrgan)) | bonusHP /= 0]+      b = actorTemplate trunkId bnumber finalHP calm pos lid fid bproj+      withTrunk =+        b { bweapon = if IA.checkFlag Ability.Meleeable arItem then 1 else 0+          , bweapBenign =+              if IA.checkFlag Ability.Meleeable arItem+                 && IA.checkFlag Ability.Benign arItem then 1 else 0 }+      bodyTweaked = tweakBody withTrunk+  aid <- getsServer sacounter+  modifyServer $ \ser -> ser {sacounter = succ aid}+  execUpdAtomic $ UpdCreateActor aid bodyTweaked [(trunkId, itemBase)]+  unless bproj $ do+    steamGearCur <- getsServer steamGearCur+    let gearList = case bnumberTeam of+          Nothing -> []+          Just (number, teamContinuity) ->+            case teamContinuity `EM.lookup` steamGearCur of+              Nothing -> []+              Just im -> IM.findWithDefault [] number im+    -- Create, register and insert all initial actor items, including+    -- the bonus health organs from difficulty setting.+    forM_ (healthOrgans ++ map (Nothing,) (IK.ikit itemKind))+          $ \(mk, (ikGrp, cstore)) -> do+     -- TODO: remove ASAP. This is a hack that prevents AI from stealing+     -- backstories until there is enough of them in Allure.+     -- Instead, pre-generate 20 player heroes to make sure all unique+     -- backstories are available to the player and so that the order+     -- of games played doesn't affect their availability.+     if ikGrp == DefsInternal.GroupName "backstory"+        && isJust bnumberTeam+        && (snd <$> bnumberTeam) /= Just teamExplorer+     then return ()+     else do+      let container = CActor aid cstore+      Level{ldepth} <- getLevel lid+      mIidEtc <- case lookup ikGrp gearList of+        Nothing -> do+          let itemFreq = [(ikGrp, 1)]+          -- Power depth of new items unaffected by number of spawned actors.+          freq <- prepareItemKind 0 ldepth itemFreq+          mIidEtc <- rollAndRegisterItem False ldepth freq container mk+          case (bnumberTeam, mIidEtc) of+            (Just (number, teamContinuity), Just (_, (itemFull2, _))) -> do+              let arItem2 = aspectRecordFull itemFull2+                  inMetaGame = IA.checkFlag Ability.MetaGame arItem2+                  itemKindId2 = itemKindId itemFull2+              when inMetaGame $ do+                let altInner ml = Just $ (ikGrp, itemKindId2) : fromMaybe [] ml+                    alt mim =+                      Just $ IM.alter altInner number $ fromMaybe IM.empty mim+                modifyServer $ \ser ->+                  ser {steamGear = EM.alter alt teamContinuity $ steamGear ser}+            _ -> return ()+          return mIidEtc+        Just itemKindId2 -> do+          let gearListNew = delete (ikGrp, itemKindId2) gearList+              (number, teamContinuity) = fromJust bnumberTeam+              alt mim =+                Just $ IM.insert number gearListNew $ fromMaybe IM.empty mim+          modifyServer $ \ser ->+            ser {steamGearCur = EM.alter alt teamContinuity steamGearCur}+          let itemKind2 = okind coitem itemKindId2+              freq = pure (ikGrp, itemKindId2, itemKind2)+          rollAndRegisterItem False ldepth freq container mk+      case mIidEtc of+        Nothing -> error $ "" `showFailure` (lid, ikGrp, container, mk)+        Just (iid, (itemFull2, _)) ->+          when (cstore /= CGround) $+            -- The items are created owned by actors, so won't be picked up,+            -- so we have to discover them now, if eligible.+            discoverIfMinorEffects container iid (itemKindId itemFull2)+  return aid+addActorIid _ _ _ _ _ _ _ = error "addActorIid: server ignorant about an item"++discoverIfMinorEffects :: MonadServerAtomic m+                       => Container -> ItemId -> ContentId ItemKind -> m ()+discoverIfMinorEffects c iid itemKindId = do+  COps{coitem} <- getsState scops+  discoAspect <- getsState sdiscoAspect+  let arItem = discoAspect EM.! iid+      itemKind = okind coitem itemKindId+   -- Otherwise, discover by use when item's effects get activated later on.+  when (IA.onlyMinorEffects arItem itemKind+        && not (IA.isHumanTrinket itemKind)) $+    execUpdAtomic $ UpdDiscover c iid itemKindId arItem++pickWeaponServer :: MonadServer m+                 => ActorId -> ActorId -> m (Maybe (ItemId, CStore))+pickWeaponServer source target = do+  eqpAssocs <- getsState $ kitAssocs source [CEqp]+  bodyAssocs <- getsState $ kitAssocs source [COrgan]+  actorSk <- currentSkillsServer source+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  let kitAssRaw = eqpAssocs ++ bodyAssocs+      forced = bproj sb+      kitAss | forced = kitAssRaw  -- for projectiles, anything is weapon+             | otherwise =+                 filter (IA.checkFlag Ability.Meleeable+                         . aspectRecordFull . fst . snd) kitAssRaw+      benign itemFull = let arItem = aspectRecordFull itemFull+                        in IA.checkFlag Ability.Benign arItem+  -- Server ignores item effects or it would leak item discovery info.+  -- Hence, weapons with powerful burning or wouding are undervalued.+  -- In particular, it even uses weapons that would heal an opponent.+  -- But server decides only in exceptiona cases, e.g. projectile collision+  -- or melee in place of an impossible displace. Otherwise, client decides.+  strongest <- pickWeaponM False Nothing kitAss actorSk source+  case strongest of+    [] -> return Nothing+    (_, _, _, _, _, (itemFull, _)) : _ | not forced+                                         && benign itemFull && bproj tb ->+      return Nothing  -- if strongest is benign, don't waste fun on a projectile+    iis@((value1, hasEffect1, timeout1, _, _, _) : _) -> do+      let minIis = takeWhile (\(value, hasEffect, timeout, _, _, _) ->+                                 value == value1+                                 && hasEffect == hasEffect1+                                 && timeout == timeout1)+                             iis+      (_, _, _, _, iid, _) <- rndToAction $ oneOf minIis+      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp+      return $ Just (iid, cstore)++-- @MonadStateRead@ would be enough, but the logic is sound only on server.+currentSkillsServer :: MonadServer m => ActorId -> m Ability.Skills+currentSkillsServer aid  = do+  body <- getsState $ getActorBody aid+  mleader <- getsState $ gleader . (EM.! bfid body) . sfactionD+  getsState $ actorCurrentSkills mleader aid++getCacheLucid :: MonadServer m => LevelId -> m FovLucid+getCacheLucid lid = do+  fovClearLid <- getsServer sfovClearLid+  fovLitLid <- getsServer sfovLitLid+  fovLucidLid <- getsServer sfovLucidLid+  let getNewLucid = getsState $ \s ->+        lucidFromLevel fovClearLid fovLitLid s lid (sdungeon s EM.! lid)+  case EM.lookup lid fovLucidLid of+    Just (FovValid fovLucid) -> return fovLucid+    _ -> do+      newLucid <- getNewLucid+      modifyServer $ \ser ->+        ser {sfovLucidLid = EM.insert lid (FovValid newLucid)+                            $ sfovLucidLid ser}+      return newLucid++getCacheTotal :: MonadServer m => FactionId -> LevelId -> m CacheBeforeLucid+getCacheTotal fid lid = do+  sperCacheFidOld <- getsServer sperCacheFid+  let perCacheOld = sperCacheFidOld EM.! fid EM.! lid+  case ptotal perCacheOld of+    FovValid total -> return total+    FovInvalid -> do+      actorMaxSkills <- getsState sactorMaxSkills+      fovClearLid <- getsServer sfovClearLid+      getActorB <- getsState $ flip getActorBody+      let perActorNew =+            perActorFromLevel (perActor perCacheOld) getActorB+                              actorMaxSkills (fovClearLid EM.! lid)+          -- We don't check if any actor changed, because almost surely one is.+          -- Exception: when an actor is destroyed, but then union differs, too.+          total = totalFromPerActor perActorNew+          perCache = PerceptionCache { ptotal = FovValid total+                                     , perActor = perActorNew }+          fperCache = EM.adjust (EM.insert lid perCache) fid+      modifyServer $ \ser -> ser {sperCacheFid = fperCache $ sperCacheFid ser}+      return total++allGroupItems :: MonadServerAtomic m+              => CStore -> GroupName ItemKind -> ActorId+              -> m [(ItemId, ItemQuant)]+allGroupItems store grp target = do+  COps{coitem} <- getsState scops+  b <- getsState $ getActorBody target+  assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store+  getKindId <- getsState $ flip getIidKindIdServer+  let assocsKindId = map (\as@(iid, _) -> (getKindId iid, as)) assocsCStore+      hasGroup (itemKindId, _) =+        maybe False (> 0) $ lookup grp $ IK.ifreq $ okind coitem itemKindId+  return $! map snd $ sortBy (comparing fst) $ filter hasGroup assocsKindId++addCondition :: MonadServerAtomic m+             => Bool -> GroupName ItemKind -> ActorId -> m ()+addCondition verbose name aid = do+  b <- getsState $ getActorBody aid+  Level{ldepth} <- getLevel $ blid b+  let c = CActor aid COrgan+  -- Power depth of new items unaffected by number of spawned actors.+  freq <- prepareItemKind 0 ldepth [(name, 1)]+  mresult <- rollAndRegisterItem verbose ldepth freq c Nothing+  assert (isJust mresult) $ return ()++removeConditionSingle :: MonadServerAtomic m+                      => GroupName ItemKind -> ActorId -> m Int+removeConditionSingle name aid = do+  let c = CActor aid COrgan+  is <- allGroupItems COrgan name aid+  case is of+    [(iid, (nAll, itemTimer))] -> do+      execUpdAtomic $ UpdLoseItem False iid (1, itemTimer) c+      return $ nAll - 1+    _ -> error $ "missing or multiple item" `showFailure` (name, is)++addSleep :: MonadServerAtomic m => ActorId -> m ()+addSleep aid = do+  b <- getsState $ getActorBody aid+  addCondition True IK.S_ASLEEP aid+  execUpdAtomic $ UpdWaitActor aid (bwatch b) WSleep++removeSleepSingle :: MonadServerAtomic m => ActorId -> m ()+removeSleepSingle aid = do+  nAll <- removeConditionSingle IK.S_ASLEEP aid+  when (nAll == 0) $+    execUpdAtomic $ UpdWaitActor aid WWake WWatch++addKillToAnalytics :: MonadServerAtomic m+                   => ActorId -> KillHow -> FactionId -> ItemId -> m ()+addKillToAnalytics aid killHow fid iid = do+  actorD <- getsState sactorD+  case EM.lookup aid actorD of+    Just b ->+      modifyServer $ \ser ->+        ser { sfactionAn = addFactionKill (bfid b) killHow fid iid+                           $ sfactionAn ser+            , sactorAn = addActorKill aid killHow fid iid+                         $ sactorAn ser }+    Nothing -> return ()  -- killer dead, too late to assign blame
+ engine-src/Game/LambdaHack/Server/DebugM.hs view
@@ -0,0 +1,115 @@+-- | Debug output for requests and responses.+module Game.LambdaHack.Server.DebugM+  ( debugResponse+  , debugRequestAI, debugRequestUI+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , debugShow, debugPretty, debugPlain, DebugAid(..), debugAid+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Int (Int64)+import qualified Data.Text as T+import qualified Text.Show.Pretty as Show.Pretty++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client (Response (..))+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Types+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++-- We debug these on the server, not on the clients, because we want+-- a single log, knowing the order in which the server received requests+-- and sent responseQs. Clients interleave and block non-deterministically+-- so their logs would be harder to interpret.++debugShow :: Show a => a -> Text+debugShow = T.pack . Show.Pretty.ppShow++debugResponse :: MonadServer m => FactionId -> Response -> m ()+debugResponse fid resp = case resp of+  RespUpdAtomic _ cmd@UpdPerception{} -> debugPlain fid "RespUpdAtomic" cmd+  RespUpdAtomic _ cmd@UpdResume{} -> debugPlain fid "RespUpdAtomic" cmd+  RespUpdAtomic _ cmd@UpdRestart{} -> debugPlain fid "RespUpdAtomic" cmd+  RespUpdAtomic _ cmd@UpdSpotTile{} -> debugPlain fid "RespUpdAtomic" cmd+  RespUpdAtomic _ cmd@(UpdCreateActor aid _ _) -> do+    d <- debugAid aid "UpdCreateActor"+    serverPrint d+    debugPretty fid "RespUpdAtomic" cmd+  RespUpdAtomic _ cmd@(UpdSpotActor aid _) -> do+    d <- debugAid aid "UpdSpotActor"+    serverPrint d+    debugPretty fid "RespUpdAtomic" cmd+  RespUpdAtomic _ cmd -> debugPretty fid "RespUpdAtomic" cmd+  RespUpdAtomicNoState cmd@UpdPerception{} ->+    debugPlain fid "RespUpdAtomicNoState" cmd+  RespUpdAtomicNoState cmd@UpdResume{} ->+    debugPlain fid "RespUpdAtomicNoState" cmd+  RespUpdAtomicNoState cmd@UpdSpotTile{} ->+    debugPlain fid "RespUpdAtomicNoState" cmd+  RespUpdAtomicNoState cmd ->+    debugPretty fid "RespUpdAtomicNoState" cmd+  RespQueryAI aid -> do+    d <- debugAid aid "RespQueryAI"+    serverPrint d+  RespSfxAtomic sfx -> do  -- not so crucial so no details+    ps <- posSfxAtomic sfx+    serverPrint $ debugShow (fid, "RespSfxAtomic" :: Text, ps)+  RespQueryUIunderAI -> serverPrint "RespQueryUIunderAI"+  RespQueryUI -> serverPrint "RespQueryUI"++debugPretty :: MonadServer m => FactionId -> Text -> UpdAtomic -> m ()+debugPretty fid t cmd = do+  ps <- posUpdAtomic cmd+  serverPrint $ debugShow (fid, t, ps, cmd)++debugPlain :: MonadServer m => FactionId -> Text -> UpdAtomic -> m ()+debugPlain fid t cmd = do+  ps <- posUpdAtomic cmd+  serverPrint $ T.pack $ show (fid, t, ps, cmd)+    -- too large for pretty printing++debugRequestAI :: MonadServer m => ActorId -> m ()+debugRequestAI aid = do+  d <- debugAid aid "AI request"+  serverPrint d++debugRequestUI :: MonadServer m => ActorId -> m ()+debugRequestUI aid = do+  d <- debugAid aid "UI request"+  serverPrint d++data DebugAid = DebugAid+  { label   :: Text+  , aid     :: ActorId+  , faction :: FactionId+  , lid     :: LevelId+  , bHP     :: Int64+  , btime   :: Maybe Time+  , btrTime :: Maybe Time+  , time    :: Time+  }+  deriving Show++debugAid :: MonadServer m => ActorId -> Text -> m Text+debugAid aid label = do+  b <- getsState $ getActorBody aid+  time <- getsState $ getLocalTime (blid b)+  btime <- getsServer $ lookupActorTime (bfid b) (blid b) aid . sactorTime+  btrTime <- getsServer $ lookupActorTime (bfid b) (blid b) aid . strajTime+  return $! debugShow DebugAid { label+                               , aid+                               , faction = bfid b+                               , lid = blid b+                               , bHP = bhp b+                               , btime+                               , btrTime+                               , time }
+ engine-src/Game/LambdaHack/Server/DungeonGen.hs view
@@ -0,0 +1,413 @@+{-# LANGUAGE TupleSections #-}+-- | The dungeon generation routine. It creates empty dungeons, without+-- actors and without items, either lying on the floor or embedded inside tiles.+module Game.LambdaHack.Server.DungeonGen+  ( FreshDungeon(..), dungeonGen+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , convertTileMaps, buildTileMap, anchorDown, buildLevel+  , snapToStairList, placeDownStairs, levelFromCave+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Monad.Trans.State.Strict as St+import           Data.Either (rights)+import qualified Data.EnumMap.Strict as EM+import qualified Data.IntMap.Strict as IM+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           System.IO (hFlush, stdout)+import           System.IO.Unsafe (unsafePerformIO)+import qualified System.Random.SplitMix32 as SM++import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.CaveKind+import           Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.PlaceKind as PK+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.Defs+import qualified Game.LambdaHack.Definition.DefsInternal as DefsInternal+import           Game.LambdaHack.Server.DungeonGen.AreaRnd+import           Game.LambdaHack.Server.DungeonGen.Cave+import           Game.LambdaHack.Server.DungeonGen.Place+import           Game.LambdaHack.Server.ServerOptions++convertTileMaps :: COps -> Bool -> Rnd (ContentId TileKind)+                -> Maybe (Rnd (ContentId TileKind)) -> Area -> TileMapEM+                -> Rnd TileMap+convertTileMaps COps{ corule=RuleContent{rWidthMax, rHeightMax}+                    , cotile+                    , coTileSpeedup }+                areAllWalkable cdefTile mpickPassable darea ltile = do+  let outerId = ouniqGroup cotile TK.S_UNKNOWN_OUTER_FENCE+      runCdefTile :: (SM.SMGen, (Int, [(Int, ContentId TileKind)]))+                  -> ( ContentId TileKind+                     , (SM.SMGen, (Int, [(Int, ContentId TileKind)])) )+      runCdefTile (gen1, (pI, assocs)) =+        let p = toEnum pI+        in if inside darea p+           then case assocs of+             (p2, t2) : rest | p2 == pI -> (t2, (gen1, (pI + 1, rest)))+             _ -> let (tile, gen2) = St.runState cdefTile gen1+                  in (tile, (gen2, (pI + 1, assocs)))+           else (outerId, (gen1, (pI + 1, assocs)))+      runUnfold gen =+        let (gen1, gen2) = SM.splitSMGen gen+        in (PointArray.unfoldrNA+              rWidthMax rHeightMax runCdefTile+              (gen1, (0, IM.assocs $ EM.enumMapToIntMap ltile)), gen2)+  converted1 <- St.state runUnfold+  case mpickPassable of+    _ | areAllWalkable -> return converted1  -- all walkable; passes OK+    Nothing -> return converted1  -- no walkable tiles for filling the map+    Just pickPassable -> do  -- some tiles walkable, so ensure connectivity+      let passes p array =+            Tile.isWalkable coTileSpeedup (array PointArray.! p)+          -- If no point blocks on both ends, then I can eventually go+          -- from bottom to top of the map and from left to right+          -- unless there are disconnected areas inside rooms).+          blocksHorizontal (Point x y) array =+            not (passes (Point (x + 1) y) array+                 || passes (Point (x - 1) y) array)+          blocksVertical (Point x y) array =+            not (passes (Point x (y + 1)) array+                 || passes (Point x (y - 1)) array)+          activeArea = fromMaybe (error $ "" `showFailure` darea) $ shrink darea+          connect included blocks walkableTile array =+            let g p c = if inside activeArea p+                           && included p+                           && not (Tile.isEasyOpen coTileSpeedup c)+                           && p `EM.notMember` ltile+                           && blocks p array+                        then walkableTile+                        else c+            in PointArray.imapA g array+      walkable2 <- pickPassable+      let converted2 = connect (even . px) blocksHorizontal walkable2 converted1+      walkable3 <- pickPassable+      let converted3 = connect (even . py) blocksVertical walkable3 converted2+      walkable4 <- pickPassable+      let converted4 =+            connect (odd . px) blocksHorizontal walkable4 converted3+      walkable5 <- pickPassable+      let converted5 =+            connect (odd . py) blocksVertical walkable5 converted4+      return converted5++buildTileMap :: COps -> Cave -> Rnd TileMap+buildTileMap cops@COps{cotile, cocave} Cave{dkind, darea, dmap} = do+  let CaveKind{cpassable, cdefTile} = okind cocave dkind+      pickDefTile = fromMaybe (error $ "" `showFailure` cdefTile)+                    <$> opick cotile cdefTile (const True)+      wcond = Tile.isEasyOpenKind+      mpickPassable =+        if cpassable+        then Just $ fromMaybe (error $ "" `showFailure` cdefTile)+                    <$> opick cotile cdefTile wcond+        else Nothing+      nwcond = not . Tile.kindHasFeature TK.Walkable+  areAllWalkable <- isNothing <$> opick cotile cdefTile nwcond+  convertTileMaps cops areAllWalkable pickDefTile mpickPassable darea dmap++anchorDown :: Y+anchorDown = 5  -- not 4, asymmetric vs up, for staircase variety;+                -- symmetry kept for @cfenceApart@ caves, to save real estate++-- Create a level from a cave.+buildLevel :: COps -> ServerOptions+           -> LevelId -> ContentId CaveKind -> CaveKind -> Int -> Int+           -> Dice.AbsDepth -> [(Point, Text)]+           -> Rnd (Level, [(Point, Text)])+buildLevel cops@COps{coplace, corule=RuleContent{..}} serverOptions+           lid dkind kc doubleDownStairs singleDownStairs+           totalDepth stairsFromUp = do+  let d = if cfenceApart kc then 1 else 0+      -- Simple rule for now: level @lid@ has depth (difficulty) @abs lid@.+      ldepth = Dice.AbsDepth $ abs $ fromEnum lid+      darea =+        let (lxPrev, lyPrev) = unzip $ map ((px &&& py) . fst) stairsFromUp+            -- Stairs take some space, hence the additions.+            lxMin = max 0+                    $ -4 - d + minimum (rWidthMax - 1 : lxPrev)+            lxMax = min (rWidthMax - 1)+                    $ 4 + d + maximum (0 : lxPrev)+            lyMin = max 0+                    $ -3 - d + minimum (rHeightMax - 1 : lyPrev)+            lyMax = min (rHeightMax - 1)+                    $ 3 + d + maximum (0 : lyPrev)+            -- Pick minimal cave size that fits all previous stairs.+            xspan = max (lxMax - lxMin + 1) $ cXminSize kc+            yspan = max (lyMax - lyMin + 1) $ cYminSize kc+            x0 = min lxMin (rWidthMax - xspan)+            y0 = min lyMin (rHeightMax - yspan)+        in fromMaybe (error $ "" `showFailure` kc)+           $ toArea (x0, y0, x0 + xspan - 1, y0 + yspan - 1)+      (lstairsDouble, lstairsSingleUp) = splitAt doubleDownStairs stairsFromUp+      pstairsSingleUp = map fst lstairsSingleUp+      pstairsDouble = map fst lstairsDouble+      pallUpStairs = pstairsDouble ++ pstairsSingleUp+      boot = let (x0, y0, x1, y1) = fromArea darea+             in rights $ map (snapToStairList 0 pallUpStairs)+                             [ Point (x0 + 4 + d) (y0 + 3 + d)+                             , Point (x1 - 4 - d) (y1 - anchorDown + 1) ]+  fixedEscape <- case cescapeFreq kc of+    [] -> return []+    escapeFreq -> do+      -- Escapes don't extend to other levels, so corners not harmful+      -- (actually neither are the other restrictions inherited from stairs+      -- placement, but we respect them to keep a uniform visual layout).+      -- Allowing corners and generating before stars, because they are more+      -- important that stairs (except the first stairs, but they are guaranteed+      -- unless the level has no incoming stairs, but if so, plenty of space).+      mepos <- placeDownStairs "escape" True serverOptions lid+                               kc darea pallUpStairs boot+      case mepos of+        Just epos -> return [(epos, escapeFreq)]+        Nothing -> return []  -- with some luck, there is an escape elsewhere+  let pescape = map fst fixedEscape+      pallUpAndEscape = pescape ++ pallUpStairs+      addSingleDown :: [Point] -> Int -> Rnd [Point]+      addSingleDown acc 0 = return acc+      addSingleDown acc k = do+        mpos <- placeDownStairs "stairs" False serverOptions lid+                                kc darea (pallUpAndEscape ++ acc) boot+        case mpos of+          Just pos -> addSingleDown (pos : acc) (k - 1)+          Nothing -> return acc  -- calling again won't change anything+  pstairsSingleDown <- addSingleDown [] singleDownStairs+  let freqDouble carried =+        filter (\(gn, _) ->+                  carried `elem` T.words (DefsInternal.fromGroupName gn))+        $ cstairFreq kc ++ cstairAllowed kc+      fixedStairsDouble = map (second freqDouble) lstairsDouble+      freqUp carried = renameFreqs (<+> "up") $ freqDouble carried+      fixedStairsUp = map (second freqUp) lstairsSingleUp+      freqDown = renameFreqs (<+> "down") $ cstairFreq kc+      fixedStairsDown = map (, freqDown) pstairsSingleDown+      pallExits = pallUpAndEscape ++ pstairsSingleDown+      fixedCenters = EM.fromList $+        fixedEscape ++ fixedStairsDouble ++ fixedStairsUp ++ fixedStairsDown+  -- Avoid completely uniform levels (e.g., uniformly merged places).+  bootExtra <- if EM.null fixedCenters then do+                 mpointExtra <-+                   placeDownStairs "extra boot" False serverOptions lid+                                   kc darea pallExits boot+                 -- With sane content, @Nothing@ should never appear.+                 return $! maybeToList mpointExtra+               else return []+  let posUp Point{..} = Point (px - 1) py+      posDn Point{..} = Point (px + 1) py+      -- This and other places ensure there is always a continuous+      -- staircase from bottom to top. This makes moving between empty+      -- level much less boring. For new levels, it may be blocked by enemies+      -- or not offer enough cover, so other staircases may be preferable.+      lstair = ( map posUp $ pstairsDouble ++ pstairsSingleUp+               , map posDn $ pstairsDouble ++ pstairsSingleDown )+  cellSize <- castDiceXY ldepth totalDepth $ ccellSize kc+  let subArea = fromMaybe (error $ "" `showFailure` kc) $ shrink darea+      area = if cfenceApart kc then subArea else darea+      (lgr, gs) = grid fixedCenters (boot ++ bootExtra) area cellSize+  dsecret <- randomWord32+  cave <- buildCave cops ldepth totalDepth darea dsecret dkind lgr gs bootExtra+  cmap <- buildTileMap cops cave+  -- The bang is needed to prevent caves memory drag until levels used.+  let !lvl = levelFromCave cops cave ldepth cmap lstair pescape+      stairCarried p0 =+        let Place{qkind} = dstairs cave EM.! p0+            freq = map (first $ T.words . tshow)+                       (PK.pfreq $ okind coplace qkind)+            carriedAll = filter (\t -> any (\(ws, _) -> t `elem` ws) freq)+                                rstairWordCarried+        in case carriedAll of+          [t] -> (p0, t)+          _ -> error $ "wrong carried stair word"+                       `showFailure` (freq, carriedAll, kc)+  return (lvl, lstairsDouble ++ map stairCarried pstairsSingleDown)++snapToStairList :: Int -> [Point] -> Point -> Either Point Point+snapToStairList _ [] p = Right p+snapToStairList a (pos : rest) p =+  let nx = if px pos > px p + 5 + a || px pos < px p - 5 - a+           then px p+           else px pos+      ny = if py pos > py p + 3 + a || py pos < py p - 3 - a+           then py p+           else py pos+      np = Point nx ny+  in if np == pos then Left np else snapToStairList a rest np++-- Places yet another staircase (or escape), taking into account only+-- the already existing stairs.+placeDownStairs :: Text -> Bool -> ServerOptions -> LevelId+                -> CaveKind -> Area -> [Point] -> [Point]+                -> Rnd (Maybe Point)+placeDownStairs object cornerPermitted serverOptions lid+                CaveKind{cminStairDist, cfenceApart} darea ps boot = do+  let dist cmin p = all (\pos -> chessDist p pos > cmin) ps+      (x0, y0, x1, y1) = fromArea darea+      -- Stairs in corners often enlarge next caves, so refrain from+      -- generating stairs, if only corner available (escapes special-cased).+      -- The bottom-right corner is exempt, becuase far from messages+      -- Also, avoid generating stairs at all on upper and left margins+      -- to keep subsequent small levels away from messages on top-right.+      rx = 9  -- enough to fit smallest stairs+      ry = 6  -- enough to fit smallest stairs+      wx = x1 - x0 + 1+      wy = y1 - y0 + 1+      notInCornerEtc Point{..} =+        cornerPermitted+        || wx < 3 * rx + 3 || wy < 3 * ry + 3  -- everything is a corner+        || px > x0 + (wx - 3) `div` 3+           && py > y0 + (wy - 3) `div` 3+      inCorner Point{..} = (px <= x0 + rx || px >= x1 - rx)+                           && (py <= y0 + ry || py >= y1 - ry)+      gpreference = if cornerPermitted then inCorner else notInCornerEtc+      f p = case snapToStairList 0 ps p of+        Left{} -> Nothing+        Right np -> let nnp = either id id $ snapToStairList 0 boot np+                    in if notInCornerEtc nnp then Just nnp else Nothing+      g p = case snapToStairList 2 ps p of+        Left{} -> Nothing+        Right np -> let nnp = either id id $ snapToStairList 2 boot np+                    in if gpreference nnp && dist cminStairDist nnp+                       then Just nnp+                       else Nothing+      focusArea = let d = if cfenceApart then 1 else 0+                  in fromMaybe (error $ "" `showFailure` darea)+                     $ toArea ( x0 + 4 + d, y0 + 3 + d+                              , x1 - 4 - d, y1 - anchorDown + 1 )+  mpos <- findPointInArea focusArea g 500 f+  -- The message fits this debugging level:+  let !_ = if isNothing mpos && sdumpInitRngs serverOptions+           then unsafePerformIO $ do+             T.hPutStrLn stdout $+                "Failed to place" <+> object <+> "on level"+                <+> tshow lid <> ", in" <+> tshow darea+             hFlush stdout+-- Not really expensive, but shouldn't disrupt normal testing nor play.+#ifdef WITH_EXPENSIVE_ASSERTIONS+             error "possible, but unexpected; alarm!"+#endif+           else ()+  return mpos++-- Build rudimentary level from a cave kind.+levelFromCave :: COps -> Cave -> Dice.AbsDepth+              -> TileMap -> ([Point], [Point]) -> [Point]+              -> Level+levelFromCave COps{coTileSpeedup} Cave{..} ldepth ltile lstair lescape =+  let f n t | Tile.isExplorable coTileSpeedup t = n + 1+            | otherwise = n+      lexpl = PointArray.foldlA' f 0 ltile+  in Level+       { lkind = dkind+       , ldepth+       , lfloor = EM.empty+       , lembed = EM.empty+       , lbig = EM.empty+       , lproj = EM.empty+       , ltile+       , lentry = dentry+       , larea = darea+       , lsmell = EM.empty+       , lstair+       , lescape+       , lseen = 0+       , lexpl+       , ltime = timeZero+       , lnight = dnight+       }++-- | Freshly generated and not yet populated dungeon.+data FreshDungeon = FreshDungeon+  { freshDungeon    :: Dungeon        -- ^ maps for all levels+  , freshTotalDepth :: Dice.AbsDepth  -- ^ absolute dungeon depth+  }++-- | Generate the dungeon for a new game.+dungeonGen :: COps -> ServerOptions -> Caves -> Rnd FreshDungeon+dungeonGen cops@COps{cocave} serverOptions caves = do+  let shuffleSegment :: ([Int], [GroupName CaveKind])+                     -> Rnd [(Int, GroupName CaveKind)]+      shuffleSegment (ns, l) = assert (length ns == length l) $ do+        lShuffled <- shuffle l+        return $! zip ns lShuffled+  cavesShuffled <- mapM shuffleSegment caves+  let cavesFlat = concat cavesShuffled+      absKeys = map (abs . fst) cavesFlat+      freshTotalDepth = Dice.AbsDepth $ maximum $ 10 : absKeys+      getCaveKindNum :: (Int, GroupName CaveKind)+                     -> Rnd ((LevelId, ContentId CaveKind, CaveKind), Int)+      getCaveKindNum (ln, genName) = do+        dkind <- fromMaybe (error $ "" `showFailure` genName)+                 <$> opick cocave genName (const True)+        let kc = okind cocave dkind+            ldepth = Dice.AbsDepth $ abs ln+        maxStairsNum <- castDice ldepth freshTotalDepth $ cmaxStairsNum kc+        return ((toEnum ln, dkind, kc), maxStairsNum)+  caveKindNums <- mapM getCaveKindNum cavesFlat+  let (caveKinds, caveNums) = unzip caveKindNums+      caveNumNexts = zip caveNums $ drop 1 caveNums ++ [0]+      placeStairs :: ([(Int, Int, Int)], Int)+                  -> (Int, Int)+                  -> ([(Int, Int, Int)], Int)+      placeStairs (acc, nstairsFromUp) (maxStairsNum, maxStairsNumNext) =+        let !_A1 = assert (nstairsFromUp <= maxStairsNum) ()+            -- Any stairs coming from above are kept and if they exceed+            -- @maxStairsNumNext@, the remainder ends here.+            -- If they don't exceed the minimum of @maxStairsNum@+            -- and @maxStairsNumNext@, the difference is filled up+            -- with single downstairs. The computation below maximizes+            -- the number of stairs at the cost of breaking some long+            -- staircases, except for the first one, which is always kept.+            -- Even without this exception, sometimes @maxStairsNum@+            -- could not be reached.+            doubleKept =+              minimum [1, nstairsFromUp, maxStairsNum, maxStairsNumNext]+            nstairsFromUp1 = nstairsFromUp - doubleKept+            maxStairsNum1 = maxStairsNum - doubleKept+            maxStairsNumNext1 = maxStairsNumNext - doubleKept+            singleDownStairs =+              min maxStairsNumNext1 $ maxStairsNum1 - nstairsFromUp1+            remainingNext = maxStairsNumNext1 - singleDownStairs+            doubleDownStairs = doubleKept+                               + min nstairsFromUp1 remainingNext+            !_A2 = assert (singleDownStairs >= 0) ()+            !_A3 = assert (doubleDownStairs >= doubleKept) ()+        in ( (nstairsFromUp, doubleDownStairs, singleDownStairs) : acc+           , doubleDownStairs + singleDownStairs )+      (caveStairs, nstairsFromUpLast) = foldl' placeStairs ([], 0) caveNumNexts+      caveZipped = assert (nstairsFromUpLast == 0)+                   $ zip caveKinds (reverse caveStairs)+      placeCaveKind :: ([(LevelId, Level)], [(Point, Text)])+                     -> ( (LevelId, ContentId CaveKind, CaveKind)+                        , (Int, Int, Int) )+                     -> Rnd ([(LevelId, Level)], [(Point, Text)])+      placeCaveKind (lvls, stairsFromUp)+                    ( (lid, dkind, kc)+                    , (nstairsFromUp, doubleDownStairs, singleDownStairs) ) = do+        let !_A = assert (length stairsFromUp == nstairsFromUp) ()+        (newLevel, ldown2) <-+          -- lstairUp for the next level is lstairDown for the current level+          buildLevel cops serverOptions+                     lid dkind kc doubleDownStairs singleDownStairs+                     freshTotalDepth stairsFromUp+        return ((lid, newLevel) : lvls, ldown2)+  (levels, stairsFromUpLast) <- foldlM' placeCaveKind ([], []) caveZipped+  let freshDungeon = assert (null stairsFromUpLast) $ EM.fromList levels+  return $! FreshDungeon{..}
+ engine-src/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs view
@@ -0,0 +1,363 @@+-- | Operations on the 'Area' type that involve random numbers.+module Game.LambdaHack.Server.DungeonGen.AreaRnd+  ( -- * Picking points inside areas+    mkFixed, pointInArea, findPointInArea, mkVoidRoom, mkRoom+    -- * Choosing connections+  , connectGrid, randomConnection+    -- * Plotting corridors+  , HV(..), Corridor, connectPlaces+  , SpecialArea(..), grid+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , connectGrid', sortPoint, mkCorridor, borderPlace+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Functor.Identity (runIdentity)+import qualified Data.IntSet as IS++import Game.LambdaHack.Common.Area+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.PlaceKind+import Game.LambdaHack.Core.Random+import Game.LambdaHack.Definition.Defs++-- Doesn't respect minimum sizes, because staircases are specified verbatim,+-- so can't be arbitrarily scaled up.+-- The size may be one more than what maximal size hint requests,+-- but this is safe (limited by area size) and makes up for the rigidity+-- of the fixed room sizes (e.g., that the size is always odd).+mkFixed :: (X, Y)    -- ^ maximum size+        -> Area      -- ^ the containing area, not the room itself+        -> Point     -- ^ the center point+        -> Area+mkFixed (xMax, yMax) area p@Point{..} =+  let (x0, y0, x1, y1) = fromArea area+      xradius = min ((xMax + 1) `div` 2) $ min (px - x0) (x1 - px)+      yradius = min ((yMax + 1) `div` 2) $ min (py - y0) (y1 - py)+      a = (px - xradius, py - yradius, px + xradius, py + yradius)+  in fromMaybe (error $ "" `showFailure` (a, xMax, yMax, area, p)) $ toArea a++-- | Pick a random point within an area.+pointInArea :: Area -> Rnd Point+pointInArea area = do+  let (Point x0 y0, xspan, yspan) = spanArea area+  pxy <- randomR0 (xspan * yspan - 1)+  let Point{..} = punindex xspan pxy+  return $! Point (x0 + px) (y0 + py)++-- | Find a suitable position in the area, based on random points+-- and a preference predicate and fallback acceptability predicate.+findPointInArea :: Area -> (Point -> Maybe Point)+                -> Int -> (Point -> Maybe Point)+                -> Rnd (Maybe Point)+findPointInArea area g gnumTries f =+  let (Point x0 y0, xspan, yspan) = spanArea area+      checkPoint :: Applicative m+                 => (Point -> Maybe Point) -> m (Maybe Point) -> Int+                 -> m (Maybe Point)+      {-# INLINE checkPoint #-}+      checkPoint check fallback pxyRelative =+        let Point{..} = punindex xspan pxyRelative+            pos = Point (x0 + px) (y0 + py)+        in case check pos of+          Just p -> pure $ Just p+          Nothing -> fallback+      gsearch 0 = fsearch (xspan * yspan * 10)+      gsearch count = do+        pxy <- randomR0 (xspan * yspan - 1)+        checkPoint g (gsearch (count - 1)) pxy+      fsearch 0 = return $! runIdentity $ searchAll (xspan * yspan - 1)+      fsearch count = do+        pxy <- randomR0 (xspan * yspan - 1)+        checkPoint f (fsearch (count - 1)) pxy+      searchAll (-1) = pure Nothing+      searchAll pxyRelative =+        checkPoint f (searchAll (pxyRelative - 1)) pxyRelative+  in gsearch gnumTries++-- | Create a void room, i.e., a single point area within the designated area.+mkVoidRoom :: Area -> Rnd Area+mkVoidRoom area = do+  -- Pass corridors closer to the middle of the grid area, if possible.+  let core = fromMaybe area $ shrink area+  pxy <- pointInArea core+  return $! trivialArea pxy++-- | Create a random room according to given parameters.+mkRoom :: (X, Y)    -- ^ minimum size+       -> (X, Y)    -- ^ maximum size+       -> Area      -- ^ the containing area, not the room itself+       -> Rnd Area+mkRoom (xm, ym) (xM, yM) area = do+  let (x0, y0, x1, y1) = fromArea area+      xspan = x1 - x0 + 1+      yspan = y1 - y0 + 1+      aW = (min xm xspan, min ym yspan, min xM xspan, min yM yspan)+      areaW = fromMaybe (error $ "" `showFailure` aW) $ toArea aW+  Point xW yW <- pointInArea areaW  -- roll size+  let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1))+      area1 = fromMaybe (error $ "" `showFailure` a1) $ toArea a1+  Point rx1 ry1 <- pointInArea area1  -- roll top-left corner+  let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1)+      area3 = fromMaybe (error $ "" `showFailure` a3) $ toArea a3+  return $! area3++-- 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 :: ES.EnumSet Point -> (X, Y) -> Rnd [(Point, Point)]+connectGrid voidPlaces (nx, ny) = do+  let unconnected = ES.fromDistinctAscList [ Point x y+                                           | y <- [0..ny-1], x <- [0..nx-1] ]+  -- Candidates are neighbours that are still unconnected. We start with+  -- a random choice.+  p <- oneOf $ ES.elems $ unconnected ES.\\ voidPlaces+  let candidates = ES.singleton p+  connectGrid' voidPlaces (nx, ny) unconnected candidates []++connectGrid' :: ES.EnumSet Point -> (X, Y)+             -> ES.EnumSet Point -> ES.EnumSet Point+             -> [(Point, Point)]+             -> Rnd [(Point, Point)]+connectGrid' voidPlaces (nx, ny) unconnected candidates !acc+  | unconnected `ES.isSubsetOf` voidPlaces = return acc+  | otherwise = do+      let candidatesBest = candidates ES.\\ voidPlaces+      c <- oneOf $ ES.elems $ if ES.null candidatesBest+                               then candidates+                               else candidatesBest+      -- potential new candidates:+      let ns = ES.fromList $ vicinityCardinal nx ny c+          nu = ES.delete c unconnected  -- new unconnected+          -- (new candidates, potential connections):+          (nc, ds) = ES.partition (`ES.member` nu) ns+      new <- if ES.null ds+             then return id+             else do+               d <- oneOf (ES.elems ds)+               return (sortPoint (c, d) :)+      connectGrid' voidPlaces (nx, ny) nu+        (ES.delete c (candidates `ES.union` nc)) (new acc)++-- | Sort the sequence of two points, in the derived lexicographic order.+sortPoint :: (Point, Point) -> (Point, Point)+sortPoint (a, b) | a <= b    = (a, b)+                 | otherwise = (b, a)++-- | Pick a single random connection between adjacent areas within a grid.+randomConnection :: (X, Y) -> Rnd (Point, Point)+randomConnection (nx, ny) =+  assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do+  rb <- oneOf [False, True]+  if rb && nx > 1 || ny <= 1+  then do+    rx <- randomR0 (nx - 2)+    ry <- randomR0 (ny - 1)+    return (Point rx ry, Point (rx+1) ry)+  else do+    rx <- randomR0 (nx - 1)+    ry <- randomR0 (ny - 2)+    return (Point rx ry, Point rx (ry+1))++-- Plotting individual corridors between two areas++-- | The choice of horizontal and vertical orientation.+data HV = Horiz | Vert+  deriving Eq++-- | The coordinates of consecutive fields of a corridor.+type Corridor = (Point, Point, Point, Point)++-- | Create a corridor, either horizontal or vertical, with+-- a possible intermediate part that is in the opposite direction.+-- 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            -- ^ orientation of the starting section+           -> Point         -- ^ starting point+           -> Bool          -- ^ starting is inside @FGround@ or @FFloor@+           -> Point         -- ^ ending point+           -> Bool          -- ^ ending is inside @FGround@ or @FFloor@+           -> Area          -- ^ the area containing the intermediate point+           -> Rnd Corridor  -- ^ straight sections of the corridor+mkCorridor hv (Point x0 y0) p0floor (Point x1 y1) p1floor area = do+  Point rxRaw ryRaw <- pointInArea area+  let (sx0, sy0, sx1, sy1) = fromArea area+      -- Avoid corridors that run along @FGround@ or @FFloor@ fence,+      -- unless not possible.+      rx = if | rxRaw == sx0 + 1 && p0floor -> sx0+              | rxRaw == sx1 - 1 && p1floor -> sx1+              | otherwise -> rxRaw+      ry = if | ryRaw == sy0 + 1 && p0floor -> sy0+              | ryRaw == sy1 - 1 && p1floor -> sy1+              | otherwise -> ryRaw+  return $! case hv of+    Horiz -> (Point x0 y0, Point rx y0, Point rx y1, Point x1 y1)+    Vert  -> (Point x0 y0, Point x0 ry, Point x1 ry, Point x1 y1)++-- | Try to connect two interiors of places with a corridor.+-- Choose entrances some steps away from the edges, if the place+-- is big enough. Note that with @pfence == FNone@, the inner area considered+-- is the strict interior of the place, without the outermost tiles.+--+-- The corridor connects (touches) the inner areas and the turning point+-- of the corridor (if any) is outside of the outer areas+-- and inside the grid areas.+connectPlaces :: (Area, Fence, Area) -> (Area, Fence, Area)+              -> Rnd (Maybe Corridor)+connectPlaces (_, _, sg) (_, _, tg) | sg == tg = return Nothing+connectPlaces s3@(sqarea, spfence, sg) t3@(tqarea, tpfence, tg) = do+  let (sa, so, stiny) = borderPlace sqarea spfence+      (ta, to, ttiny) = borderPlace tqarea tpfence+      trim area =+        let (x0, y0, x1, y1) = fromArea area+            dx = case (x1 - x0) `div` 2 of+              0 -> 0+              1 -> 1+              2 -> 1+              3 -> 1+              _ -> 3+            dy = case (y1 - y0) `div` 2 of+              0 -> 0+              1 -> 1+              2 -> 1+              3 -> 1+              _ -> 3+        in fromMaybe (error $ "" `showFailure` (area, s3, t3))+           $ toArea (x0 + dx, y0 + dy, x1 - dx, y1 - dy)+  Point sx sy <- pointInArea $ trim sa+  Point tx ty <- pointInArea $ trim ta+  -- If the place (e.g., void place) is slim (at most 2-tile wide, no fence),+  -- overwrite it with corridor. The place may not even be built (e.g., void)+  -- and the overwrite ensures connections through it are not broken.+  let (_, _, sax1Raw, say1Raw) = fromArea sa  -- inner area+      sslim = stiny && spfence == FNone+      (sax1, say1) = if sslim+                     then (sax1Raw - 1, say1Raw - 1)+                     else (sax1Raw, say1Raw)+      (tax0Raw, tay0Raw, _, _) = fromArea ta+      tslim = ttiny && tpfence == FNone+      (tax0, tay0) = if tslim+                     then (tax0Raw + 1, tay0Raw + 1)+                     else (tax0Raw, tay0Raw)+      (_, _, sox1, soy1) = fromArea so  -- outer area+      (tox0, toy0, _, _) = fromArea to+      (sgx0, sgy0, sgx1, sgy1) = fromArea sg  -- grid area+      (tgx0, tgy0, tgx1, tgy1) = fromArea tg+      (hv, area, p0, p1)+        | sgx1 == tgx0 =+          let x0 = if sgy0 <= ty && ty <= sgy1 then sox1 + 1 else sgx1+              x1 = if tgy0 <= sy && sy <= tgy1 then tox0 - 1 else sgx1+          in case toArea (x0, min sy ty, x1, max sy ty) of+            Just a -> (Horiz, a, Point (sax1 + 1) sy, Point (tax0 - 1) ty)+            Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3)+        | otherwise = assert (sgy1 == tgy0) $+          let y0 = if sgx0 <= tx && tx <= sgx1 then soy1 + 1 else sgy1+              y1 = if tgx0 <= sx && sx <= tgx1 then toy0 - 1 else sgy1+          in case toArea (min sx tx, y0, max sx tx, y1) of+            Just a -> (Vert, a, Point sx (say1 + 1), Point tx (tay0 - 1))+            Nothing -> error $ "" `showFailure` (sx, sy, tx, ty, s3, t3)+      nin p = not $ inside sa p || inside ta p+      !_A = assert (sslim || tslim+                    || allB nin [p0, p1] `blame` (sx, sy, tx, ty, s3, t3)) ()+  cor@(c1, c2, c3, c4) <- mkCorridor hv p0 (sa == so) p1 (ta == to) area+  let !_A2 = assert (sslim || tslim || allB nin [c1, c2, c3, c4]+                     `blame` (cor, sx, sy, tx, ty, s3, t3)) ()+  return $ Just cor++borderPlace :: Area -> Fence -> (Area, Area, Bool)+borderPlace qarea pfence = case pfence of+  FWall -> (qarea, expand qarea, False)+  FFloor  -> (qarea, qarea, False)+  FGround -> (qarea, qarea, False)+  FNone -> case shrink qarea of+    Nothing -> (qarea, qarea, True)+    Just sr -> (sr, qarea, False)++data SpecialArea =+    SpecialArea Area+  | SpecialFixed Point (Freqs PlaceKind) Area+  | SpecialMerged SpecialArea Point+  deriving Show++-- | Divide uniformly a larger area into the given number of smaller areas+-- overlapping at the edges.+--+-- The list of fixed centers (some important points inside)+-- of (non-overlapping) areas is given. Incorporate those,+-- with as little disruption, as possible.+-- Assume each of four boundaries of the cave are covered by a fixed centre.+grid :: EM.EnumMap Point (Freqs PlaceKind) -> [Point] -> Area -> (X, Y)+     -> ((X, Y), EM.EnumMap Point SpecialArea)+grid fixedCenters boot area cellSize =+  let (x0, y0, x1, y1) = fromArea area+      f zsize z1 n prev (c1 : c2 : rest) =+        let len = c2 - c1+            cn = len * n `div` zsize+        in -- traceShow ( zsize, z1, n, prev, len, cn+           --           , len `div` max 1 (2 * cn) ) $+           if cn < 2+           then let mid1 = (c1 + c2) `div` 2+                    mid2 = (c1 + c2) `divUp` 2+                    mid = if mid1 - prev > 4 then mid1 else mid2+                in (prev, mid, Just c1) : f zsize z1 n mid (c2 : rest)+           else (prev, c1 + len `div` (2 * cn), Just c1)+                : [ ( c1 + len * (2 * z - 1) `div` (2 * cn)+                    , c1 + len * (2 * z + 1) `div` (2 * cn)+                    , Nothing )+                  | z <- [1 .. cn - 1] ]+                ++ f zsize z1 n (c1 + len * (2 * cn - 1) `div` (2 * cn))+                     (c2 : rest)+      f _ z1 _ prev [c1] = [(prev, z1, Just c1)]+      f _ _ _ _ [] = error $ "empty list of centers" `showFailure` fixedCenters+      (xCenters, yCenters) = IS.fromList *** IS.fromList+                             $ unzip $ map (px &&& py) $ EM.keys fixedCenters+      distFromIS is z =+        - minimum (maxBound : map (\i -> abs (i - z)) (IS.toList is))+      xboot = nub $ sortOn (distFromIS xCenters)+              $ filter (`IS.notMember` xCenters) $ map px boot+      yboot = nub $ sortOn (distFromIS yCenters)+              $ filter (`IS.notMember` yCenters) $ map py boot+      -- Don't let boots ignore cell size too much, esp. in small caves.+      xcellsInArea = (x1 - x0 + 1) `div` fst cellSize+      ycellsInArea = (y1 - y0 + 1) `div` snd cellSize+      xbootN = assert (xcellsInArea > 0) $ xcellsInArea - IS.size xCenters+      ybootN = assert (ycellsInArea > 0) $ ycellsInArea - IS.size yCenters+      xset = xCenters `IS.union` IS.fromList (take xbootN xboot)+      yset = yCenters `IS.union` IS.fromList (take ybootN yboot)+      xsize = IS.findMax xset - IS.findMin xset+      ysize = IS.findMax yset - IS.findMin yset+      -- This is precisely how the cave will be divided among places,+      -- if there are no fixed centres except at boot coordinates.+      -- In any case, places, except for at boot points and fixed centres,+      -- are guaranteed at least the rolled minimal size of their+      -- enclosing cell (with one shared fence). Fixed centres are guaranteed+      -- a size between the cave cell size and the one implied by their+      -- placement wrt to cave fence and other fixed centers.+      lgrid = ( xsize `div` fst cellSize+              , ysize `div` snd cellSize )+      xallSegments = zip [0..] $ f xsize x1 (fst lgrid) x0 $ IS.toList xset+      yallSegments = zip [0..] $ f ysize y1 (snd lgrid) y0 $ IS.toList yset+  in -- traceShow (xallSegments, yallSegments) $+     ( (length xallSegments, length yallSegments)+     , EM.fromDistinctAscList+         [ ( Point x y+           , case (mcx, mcy) of+               (Just cx, Just cy) ->+                 case EM.lookup (Point cx cy) fixedCenters of+                   Nothing -> SpecialArea sarea+                   Just placeFreq -> SpecialFixed (Point cx cy) placeFreq sarea+               _ -> SpecialArea sarea )+         | (y, (cy0, cy1, mcy)) <- yallSegments+         , (x, (cx0, cx1, mcx)) <- xallSegments+         , let sarea = fromMaybe (error $ "" `showFailure` (x, y))+                       $ toArea (cx0, cy0, cx1, cy1) ] )
+ engine-src/Game/LambdaHack/Server/DungeonGen/Cave.hs view
@@ -0,0 +1,366 @@+-- | Generation of caves (not yet inhabited dungeon levels) from cave kinds.+module Game.LambdaHack.Server.DungeonGen.Cave+  ( Cave(..), buildCave+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , pickOpening+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Key (mapWithKeyM)+import           Data.Word (Word32)++import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.CaveKind+import           Game.LambdaHack.Content.PlaceKind+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.DungeonGen.AreaRnd+import           Game.LambdaHack.Server.DungeonGen.Place++-- | The type of caves (not yet inhabited dungeon levels).+data Cave = Cave+  { dkind   :: ContentId CaveKind  -- ^ the kind of the cave+  , darea   :: Area                -- ^ map area of the cave+  , dmap    :: TileMapEM           -- ^ tile kinds in the cave+  , dstairs :: EM.EnumMap Point Place+                                   -- ^ stair places indexed by their center+  , dentry  :: EM.EnumMap Point PlaceEntry+                                   -- ^ room entrances in the cave+  , dnight  :: Bool                -- ^ whether the cave is dark+  }+  deriving Show++{- |+Generate a cave using an algorithm inspired by the original Rogue,+as follows (in gross simplification):++* 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 some of the 9 grid cells a room is placed at a random position+  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, because not each cell holds a room.+-}+buildCave :: COps                -- ^ content definitions+          -> Dice.AbsDepth       -- ^ depth of the level to generate+          -> Dice.AbsDepth       -- ^ absolute depth+          -> Area                -- ^ map area of the cave+          -> Word32              -- ^ secret tile seed+          -> ContentId CaveKind  -- ^ cave kind to use for generation+          -> (X, Y)              -- ^ the dimensions of the grid of places+          -> EM.EnumMap Point SpecialArea  -- ^ pos of stairs, etc.+          -> [Point]             -- ^ boot positions to be treated as fixed+          -> Rnd Cave+buildCave cops@COps{cocave, coplace, cotile, coTileSpeedup}+          ldepth totalDepth darea dsecret dkind lgr@(gx, gy) gs bootExtra = do+  let kc@CaveKind{..} = okind cocave dkind+  darkCorTile <- fromMaybe (error $ "" `showFailure` cdarkCorTile)+                 <$> opick cotile cdarkCorTile (const True)+  litCorTile <- fromMaybe (error $ "" `showFailure` clitCorTile)+                <$> opick cotile clitCorTile (const True)+  dnight <- oddsDice ldepth totalDepth cnightOdds+  let createPlaces = do+        minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize+        maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize+        let mergeFixed :: EM.EnumMap Point SpecialArea+                       -> (Point, SpecialArea)+                       -> EM.EnumMap Point SpecialArea+            mergeFixed !gs0 (!i, !special) =+              let mergeSpecial ar p2 f =+                    case EM.lookup p2 gs0 of+                      Just (SpecialArea ar2) ->+                        let aSum = sumAreas ar ar2+                            sp = SpecialMerged (f aSum) p2+                        in EM.insert i sp $ EM.delete p2 gs0+                      _ -> gs0+                  mergable :: X -> Y -> Maybe HV+                  mergable x y = case EM.lookup (Point x y) gs0 of+                    Just (SpecialArea ar) ->+                      let (_, xspan, yspan) = spanArea ar+                          isFixed p =+                            p `elem` bootExtra+                            || case gs EM.! p of+                                 SpecialFixed{} -> True+                                 _ -> False+                      in if -- Limit (the aggresive) merging of normal places+                            -- and leave extra place for merging stairs.+                            | any isFixed+                              $ vicinityCardinal gx gy (Point x y) -> Nothing+                            -- Bias: prefer extending vertically.+                            -- Not @-2@, but @-4@, to merge aggressively.+                            | yspan - 4 < snd minPlaceSize -> Just Vert+                            | xspan - 4 < fst minPlaceSize -> Just Horiz+                            | otherwise -> Nothing+                    _ -> Nothing+              in case special of+                SpecialArea ar -> case mergable (px i) (py i) of+                  Nothing -> gs0+                  Just hv -> case hv of+                    -- Bias; vertical minimal sizes are smaller.+                    --+                    -- The commented out cases never happen, because @mergable@+                    -- is symmetric and we proceed top-left to bottom-right.+                    --+                    -- Vert | py i - 1 >= 0+                    --        && mergable (px i) (py i - 1) == Just Vert ->+                    --        mergeSpecial ar i{py = py i - 1} SpecialArea+                    Vert | py i + 1 < gy+                           && mergable (px i) (py i + 1) == Just Vert ->+                           mergeSpecial ar i{py = py i + 1} SpecialArea+                    -- Horiz | px i - 1 >= 0+                    --         && mergable (px i - 1) (py i) == Just Horiz ->+                    --         mergeSpecial ar i{px = px i - 1} SpecialArea+                    Horiz | px i + 1 < gx+                            && mergable (px i + 1) (py i) == Just Horiz ->+                            mergeSpecial ar i{px = px i + 1} SpecialArea+                    _ -> gs0+                SpecialFixed p placeGroup ar ->+                  -- If single merge is sufficient to extend the fixed place+                  -- to full size, and the merge is possible, we perform it.+                  -- An empty inner list signifies some merge is needed,+                  -- but not possible, and then we abort and don't waste space.+                  let (x0, y0, x1, y1) = fromArea ar+                      dy = 3  -- arbitrary, matches common content+                      dx = 5  -- arbitrary, matches common content+                      vics :: [[Point]]+                      vics = [ [i {py = py i - 1} | py i - 1 >= 0]  -- possible+                             | py p - y0 < dy ]  -- needed+                             ++ [ [i {py = py i + 1} | py i + 1 < gy]+                                | y1 - py p < dy ]+                             ++ [ [i {px = px i - 1} | px i - 1 >= 0]+                                | px p - x0 < dx ]+                             ++ [ [i {px = px i + 1} | px i + 1 < gx]+                                | x1 - px p < dx ]+                  in case vics of+                    [[p2]] -> mergeSpecial ar p2 (SpecialFixed p placeGroup)+                    _ -> gs0+                SpecialMerged{} -> error $ "" `showFailure` (gs, gs0, i)+            gs2 = foldl' mergeFixed gs $ EM.assocs gs+        voidPlaces <- do+          let gridArea = fromMaybe (error $ "" `showFailure` lgr)+                         $ toArea (0, 0, gx - 1, gy - 1)+              voidNum = round $+                cmaxVoid * (fromIntegralWrap :: Int -> Rational) (EM.size gs2)+              isOrdinaryArea p = case p `EM.lookup` gs2 of+                Just SpecialArea{} -> True+                _ -> False+          reps <- replicateM voidNum (pointInArea gridArea)+                    -- repetitions are OK; variance is low anyway+          return $! ES.fromList $ filter isOrdinaryArea reps+        let decidePlace :: Bool+                        -> ( TileMapEM+                           , EM.EnumMap Point (Place, Area)+                           , EM.EnumMap Point Place )+                        -> (Point, SpecialArea)+                        -> Rnd ( TileMapEM+                               , EM.EnumMap Point (Place, Area)+                               , EM.EnumMap Point Place )+            decidePlace noVoid (!m, !qls, !qstairs) (!i, !special) =+              case special of+                SpecialArea ar -> do+                  -- Reserved for corridors and the global fence.+                  let innerArea = fromMaybe (error $ "" `showFailure` (i, ar))+                                  $ shrink ar+                      !_A0 = shrink innerArea+                      !_A1 = assert (isJust _A0 `blame` (innerArea, gs, kc)) ()+                  if not noVoid && i `ES.member` voidPlaces+                  then do+                    qarea <- mkVoidRoom innerArea+                    let qkind = deadEndId+                        qmap = EM.empty+                        qfence = EM.empty+                    return (m, EM.insert i (Place{..}, ar) qls, qstairs)+                  else do+                    r <- mkRoom minPlaceSize maxPlaceSize innerArea+                    place <- buildPlace cops kc dnight darkCorTile litCorTile+                                        ldepth totalDepth dsecret+                                        r (Just innerArea) []+                    return ( EM.unions [qmap place, qfence place, m]+                           , EM.insert i (place, ar) qls+                           , qstairs )+                SpecialFixed p placeFreq ar -> do+                  -- Reserved for corridors and the global fence.+                  let innerArea = fromMaybe (error $ "" `showFailure` (i, ar))+                                  $ shrink ar+                      !_A0 = shrink innerArea+                      !_A1 = assert (isJust _A0 `blame` (innerArea, gs2, kc)) ()+                      !_A2 = assert (inside (fromJust _A0) p+                                     `blame` (p, innerArea, gs)) ()+                      r = mkFixed maxPlaceSize innerArea p+                      !_A3 = assert (isJust (shrink r)+                                     `blame` ( r, ar, p, innerArea, gs+                                             , gs2, qls, kc )) ()+                  place <- buildPlace cops kc dnight darkCorTile litCorTile+                             ldepth totalDepth dsecret r Nothing placeFreq+                  return ( EM.unions [qmap place, qfence place, m]+                         , EM.insert i (place, ar) qls+                         , EM.insert p place qstairs )+                SpecialMerged sp p2 -> do+                  (lplaces, dplaces, dstairs) <-+                    decidePlace True (m, qls, qstairs) (i, sp)+                  return ( lplaces+                         , EM.insert p2 (dplaces EM.! i) dplaces+                         , dstairs )+        places <- foldlM' (decidePlace False) (EM.empty, EM.empty, EM.empty)+                  $ EM.assocs gs2+        return (voidPlaces, lgr, places)+  (voidPlaces, lgrid, (lplaces, dplaces, dstairs)) <- createPlaces+  let lcorridorsFun :: Rnd ( EM.EnumMap Point ( ContentId TileKind+                                              , ContentId PlaceKind )+                           , TileMapEM )+      lcorridorsFun = do+        connects <- connectGrid voidPlaces lgrid+        addedConnects <- do+          let cauxNum =+                round $ cauxConnects * (fromIntegralWrap :: Int -> Rational)+                                         (uncurry (*) lgrid)+          cns <- map head . group . sort+                 <$> replicateM cauxNum (randomConnection lgrid)+          -- This allows connections through a single void room,+          -- if a non-void room on both ends.+          let notDeadEnd (p, q) =+                if | p `ES.member` voidPlaces ->+                     q `ES.notMember` voidPlaces && sndInCns p+                   | q `ES.member` voidPlaces -> fstInCns q+                   | otherwise -> True+              sndInCns p = any (\(p0, q0) ->+                q0 == p && p0 `ES.notMember` voidPlaces) cns+              fstInCns q = any (\(p0, q0) ->+                p0 == q && q0 `ES.notMember` voidPlaces) cns+          return $! filter notDeadEnd cns+        let allConnects = connects `union` addedConnects+            connectPos :: (Point, Point)+                       -> Rnd (Maybe ( ContentId PlaceKind+                                     , Corridor+                                     , ContentId PlaceKind ))+            connectPos (p0, p1) = do+              let (place0, area0) = dplaces EM.! p0+                  (place1, area1) = dplaces EM.! p1+                  savePlaces cor = (qkind place0, cor, qkind place1)+              connected <- connectPlaces+                (qarea place0, pfence $ okind coplace (qkind place0), area0)+                (qarea place1, pfence $ okind coplace (qkind place1), area1)+              return $! savePlaces <$> connected+        cs <- catMaybes <$> mapM connectPos allConnects+        let pickedCorTile = if dnight then darkCorTile else litCorTile+            digCorridorSection :: a -> Point -> Point -> EM.EnumMap Point a+            digCorridorSection a p1 p2 =+              EM.fromList $ zip (fromTo p1 p2) (repeat a)+            digCorridor (sqkind, (p1, p2, p3, p4), tqkind) =+              ( EM.union (digCorridorSection (pickedCorTile, sqkind) p1 p2)+                         (digCorridorSection (pickedCorTile, tqkind) p3 p4)+              , digCorridorSection pickedCorTile p2 p3 )+            (lplOuter, lInner) = unzip $ map digCorridor cs+        return (EM.unions lplOuter, EM.unions lInner)+  (lplcorOuter, lcorInner) <- lcorridorsFun+  -- The hacks below are instead of unionWithKeyM, which is costly.+  let mergeCor _ pl (cor, pk) = if Tile.isWalkable coTileSpeedup pl+                                then Nothing  -- tile already open+                                else Just (pl, cor, pk)+      {-# INLINE intersectionWithKeyMaybe #-}+      intersectionWithKeyMaybe combine =+        EM.mergeWithKey combine (const EM.empty) (const EM.empty)+      interCor = intersectionWithKeyMaybe mergeCor lplaces lplcorOuter  -- fast+  doorMap <- foldlM' (pickOpening cops kc lplaces litCorTile dsecret) EM.empty+                     (EM.assocs interCor)  -- very small+  let subArea = fromMaybe (error $ "" `showFailure` kc) $ shrink darea+  fence <- buildFenceRnd cops+                         cfenceTileN cfenceTileE cfenceTileS cfenceTileW subArea+  -- The obscured tile, e.g., scratched wall, stays on the server forever,+  -- only the suspect variant on client gets replaced by this upon searching.+  let sub2Area = fromMaybe (error $ "" `showFailure` kc) $ shrink subArea+      sub3Area = fromMaybe (error $ "" `showFailure` kc) $ shrink sub2Area+      likelySecret = inside sub3Area+      obscure p t = if isChancePos 1 chidden dsecret p && likelySecret p+                    then Tile.obscureAs cotile t+                    else return t+  lplacesObscured <- mapWithKeyM obscure lplaces+  let lcorOuter = EM.map fst lplcorOuter+      aroundFence Place{..} =+        if pfence (okind coplace qkind) `elem` [FFloor, FGround]+        then EM.map (const $ PAround qkind) qfence+        else EM.empty+      pickRepresentant Place{..} =+        let (representant, _, _) = spanArea qarea+        in EM.singleton representant $ PExists qkind+      dentry = EM.unions $+        [EM.map (\(_, _, pk) -> PEntry pk) interCor]+        ++ map (\(place, _) -> aroundFence place) (EM.elems dplaces)+        ++ -- for @FNone@ fences with walkable tiles on the edges+           -- that may have no intersection with corridots,+           -- particularly if @X@ is used+           map (\(place, _) -> pickRepresentant place) (EM.elems dplaces)+      dmap = EM.unions [doorMap, lplacesObscured, lcorOuter, lcorInner, fence]+        -- order matters+  return $! Cave {..}++pickOpening :: COps -> CaveKind -> TileMapEM -> ContentId TileKind -> Word32+            -> EM.EnumMap Point (ContentId TileKind)+            -> ( Point+               , (ContentId TileKind, ContentId TileKind, ContentId PlaceKind) )+            -> Rnd (EM.EnumMap Point (ContentId TileKind))+pickOpening COps{cotile, coTileSpeedup}+            CaveKind{cdoorChance, copenChance, chidden}+            lplaces litCorTile dsecret+            !acc (pos, (pl, cor, _)) = do+  let nicerCorridor =+        if Tile.isLit coTileSpeedup cor then cor+        else -- If any cardinally adjacent walkable room tile is lit,+             -- make the opening lit, as well.+             let roomTileLit p =+                   case EM.lookup p lplaces of+                     Nothing -> False+                     Just tile -> Tile.isWalkable coTileSpeedup tile+                                  && Tile.isLit coTileSpeedup tile+                 vic = vicinityCardinalUnsafe pos+             in if any roomTileLit vic then litCorTile else cor+      vicAll = vicinityUnsafe pos+      vicNewTiles = mapMaybe (`EM.lookup` acc) vicAll+  newTile <- case vicNewTiles of+    vicNewTile : _ -> return vicNewTile  -- disallow a door beside an opening+    [] -> do+      -- Openings have a certain chance to be doors and doors have a certain+      -- chance to be open.+      rd <- chance cdoorChance+      if rd then do+        let hidden = Tile.buildAs cotile pl+        doorTrappedId <- Tile.revealAs cotile hidden+        let !_A = assert (Tile.buildAs cotile doorTrappedId == doorTrappedId) ()+        -- Not all solid tiles can hide a door (or any other openable tile),+        -- so @doorTrappedId@ may in fact not be a door at all, hence the check.+        if Tile.isOpenable coTileSpeedup doorTrappedId then do  -- door created+          ro <- chance copenChance+          if ro+          then Tile.openTo cotile doorTrappedId+          else if isChancePos 1 chidden dsecret pos+               then return doorTrappedId  -- server will hide it+               else do+                 doorOpenId <- Tile.openTo cotile doorTrappedId+                 Tile.closeTo cotile doorOpenId  -- mail do nothing; OK+        else return doorTrappedId  -- assume this is what content enforces+      else return nicerCorridor+  return $! EM.insert pos newTile acc
+ engine-src/Game/LambdaHack/Server/DungeonGen/Place.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE RankNTypes #-}+-- | Generation of places from place kinds.+module Game.LambdaHack.Server.DungeonGen.Place+  ( Place(..), TileMapEM, buildPlace, isChancePos, buildFenceRnd+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , placeCheck, interiorArea, pover, buildFence, buildFenceMap+  , tilePlace+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Bits as Bits+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import           Data.Word (Word32)++import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Content.CaveKind+import           Game.LambdaHack.Content.PlaceKind+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.DungeonGen.AreaRnd++-- | The map of tile kinds in a place (and generally anywhere in a cave).+-- The map is sparse. The default tile that eventually fills the empty spaces+-- is specified in the cave kind specification with @cdefTile@.+type TileMapEM = EM.EnumMap Point (ContentId TileKind)++-- | The parameters of a place. All are immutable and rolled and fixed+-- at the time when a place is generated.+data Place = Place+  { qkind  :: ContentId PlaceKind+  , qarea  :: Area+  , qmap   :: TileMapEM+  , qfence :: TileMapEM+  }+  deriving Show++-- | For @CAlternate@ tiling, require the place be comprised+-- of an even number of whole corners, with exactly one square+-- overlap between consecutive coners and no trimming.+-- For other tiling methods, check that the area is large enough for tiling+-- the corner twice in each direction, with a possible one row/column overlap.+placeCheck :: Area       -- ^ the area to fill+           -> PlaceKind  -- ^ the kind of place to construct+           -> Bool+placeCheck r pk@PlaceKind{..} =+  case interiorArea pk r of+    Nothing -> False+    Just area ->+      let (_, xspan, yspan) = spanArea area+          dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l+          dycorner = length ptopLeft+          wholeOverlapped d dcorner = d > 1 && dcorner > 1 &&+                                      (d - 1) `mod` (2 * (dcorner - 1)) == 0+          largeEnough = xspan >= 2 * dxcorner - 1 && yspan >= 2 * dycorner - 1+      in case pcover of+        CAlternate -> wholeOverlapped xspan dxcorner &&+                      wholeOverlapped yspan dycorner+        CStretch   -> largeEnough+        CReflect   -> largeEnough+        CVerbatim  -> True+        CMirror    -> True++-- | Calculate interior room area according to fence type, based on the+-- total area for the room and it's fence. This is used for checking+-- if the room fits in the area, for digging up the place and the fence+-- and for deciding if the room is dark or lit later in the dungeon+-- generation process.+interiorArea :: PlaceKind -> Area -> Maybe Area+interiorArea kr r =+  let requiredForFence = case pfence kr of+        FWall   -> 1+        FFloor  -> 1+        FGround -> 1+        FNone   -> 0+  in if pcover kr `elem` [CVerbatim, CMirror]+     then let (Point x0 y0, xspan, yspan) = spanArea r+              dx = case ptopLeft kr of+                [] -> error $ "" `showFailure` kr+                l : _ -> T.length l+              dy = length $ ptopLeft kr+              mx = (xspan - dx) `div` 2+              my = (yspan - dy) `div` 2+          in if mx < requiredForFence || my < requiredForFence+             then Nothing+             else toArea (x0 + mx, y0 + my, x0 + mx + dx - 1, y0 + my + dy - 1)+     else case requiredForFence of+       0 -> Just r+       1 -> shrink r+       _ -> error $ "" `showFailure` kr++-- | Given a few parameters, roll and construct a 'Place' datastructure+-- and fill a cave section acccording to it.+buildPlace :: COps                -- ^ the game content+           -> CaveKind            -- ^ current cave kind+           -> Bool                -- ^ whether the cave is dark+           -> ContentId TileKind  -- ^ dark fence tile, if fence hollow+           -> ContentId TileKind  -- ^ lit fence tile, if fence hollow+           -> Dice.AbsDepth       -- ^ current level depth+           -> Dice.AbsDepth       -- ^ absolute depth+           -> Word32              -- ^ secret tile seed+           -> Area                -- ^ whole area of the place, fence included+           -> Maybe Area          -- ^ whole inner area of the grid cell+           -> Freqs PlaceKind     -- ^ optional fixed place freq+           -> Rnd Place+buildPlace cops@COps{coplace, coTileSpeedup}+           kc@CaveKind{..} dnight darkCorTile litCorTile+           levelDepth@(Dice.AbsDepth ldepth)+           totalDepth@(Dice.AbsDepth tdepth)+           dsecret r minnerArea mplaceGroup = do+  let f !q !acc !p !pk !kind =+        let rarity = linearInterpolation ldepth tdepth (prarity kind)+            !fr = q * p * rarity+        in (fr, (pk, kind)) : acc+      g (placeGroup, q) = ofoldlGroup' coplace placeGroup (f q) []+      pfreq = case mplaceGroup of+        [] -> cplaceFreq+        _ -> mplaceGroup+      placeFreq = concatMap g pfreq+      checkedFreq = filter (\(_, (_, kind)) -> placeCheck r kind) placeFreq+      freq = toFreq "buildPlace" checkedFreq+  let !_A = assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) ()+  (qkind, kr) <- frequency freq+  let smallPattern = pcover kr `elem` [CVerbatim, CMirror]+                     && (length (ptopLeft kr) < 10+                         || T.length (head (ptopLeft kr)) < 10)+  -- Below we apply a heuristics to estimate if there are floor tiles+  -- in the place that are adjacent to floor tiles of the cave and so both+  -- should have the same lit condition.+  -- A false positive is walled staircases in LambdaHack, but it's OK.+  dark <- if cpassable+             && not (dnight && Tile.isLit coTileSpeedup darkCorTile)+                  -- the colonnade can be illuminated just as the trail is+             && (pfence kr `elem` [FFloor, FGround]+                 || pfence kr == FNone && smallPattern)+          then return dnight+          else oddsDice levelDepth totalDepth cdarkOdds+  rBetter <- case minnerArea of+    Just innerArea | pcover kr `elem` [CVerbatim, CMirror] -> do+      -- A hack: if a verbatim place was rolled, redo computing the area+      -- taking into account that often much smaller portion is taken by place.+      let requiredForFence = case pfence kr of+            FWall   -> 1+            FFloor  -> 1+            FGround -> 1+            FNone   -> 0+          sizeBetter = ( 2 * requiredForFence+                         + T.length (head (ptopLeft kr))+                       , 2 * requiredForFence+                         + length (ptopLeft kr) )+      mkRoom sizeBetter sizeBetter innerArea+    _ -> return r+  let qarea = fromMaybe (error $ "" `showFailure` (kr, r))+              $ interiorArea kr rBetter+      plegend = if dark then plegendDark kr else plegendLit kr+  mOneIn <- pover cops plegend+  cmap <- tilePlace qarea kr+  let lookupOneIn :: Point -> Char -> ContentId TileKind+      lookupOneIn xy c =+        let tktk = EM.findWithDefault+                     (error $ "" `showFailure` (c, mOneIn)) c mOneIn+        in case tktk of+          (Just (k, n, tkSpice), _) | isChancePos k n dsecret xy -> tkSpice+          (_, tk) -> tk+      qmap = EM.mapWithKey lookupOneIn cmap+  qfence <- buildFence cops kc dnight darkCorTile litCorTile+                       dark (pfence kr) qarea+  return $! Place {..}++isChancePos :: Int -> Int -> Word32 -> Point -> Bool+isChancePos k' n' dsecret (Point x' y') = k' > 0 && n' > 0 &&+  let k = toEnum k'+      n = toEnum n'+      x = toEnum x'+      y = toEnum y'+      z = dsecret `Bits.rotateR` x' `Bits.xor` y + x+  in if k < n+     then z `mod` ((n + k) `divUp` k) == 0+     else z `mod` ((n + k) `divUp` n) /= 0++-- This can't be optimized by memoization (storing these results per place),+-- because it would fix random assignment of tiles to groups+-- for all instances of a place throughout dungeon. Right now the assignment+-- is fixed for any single place instance and it's consistent and interesting.+-- Even fixing this per level would make levels less interesting.+--+-- This could be precomputed for groups that contain only one tile,+-- but for these, no random rolls are performed, so little would be saved.+pover :: COps -> EM.EnumMap Char (GroupName TileKind)+      -> Rnd ( EM.EnumMap Char ( Maybe (Int, Int, ContentId TileKind)+                               , ContentId TileKind ) )+pover COps{cotile} plegend =+  let assignKN :: GroupName TileKind -> ContentId TileKind -> ContentId TileKind+               -> (Int, Int, ContentId TileKind)+      assignKN cgroup tk tkSpice =+        -- Very likely that legends have spice.+        let n = fromMaybe (error $ show cgroup)+                          (lookup cgroup (TK.tfreq (okind cotile tk)))+            k = fromMaybe (error $ show cgroup)+                          (lookup cgroup (TK.tfreq (okind cotile tkSpice)))+        in (k, n, tkSpice)+      getLegend :: GroupName TileKind+                -> Rnd ( Maybe (Int, Int, ContentId TileKind)+                       , ContentId TileKind )+      getLegend cgroup = do+        mtkSpice <- opick cotile cgroup (Tile.kindHasFeature TK.Spice)+        tk <- fromMaybe (error $ "" `showFailure` (cgroup, plegend))+              <$> opick cotile cgroup (not . Tile.kindHasFeature TK.Spice)+        return (assignKN cgroup tk <$> mtkSpice, tk)+  in mapM getLegend plegend++-- | Construct a fence around a place.+buildFence :: COps -> CaveKind -> Bool+           -> ContentId TileKind -> ContentId TileKind+           -> Bool -> Fence -> Area+           -> Rnd TileMapEM+buildFence COps{cotile} CaveKind{ccornerTile, cwallTile}+           dnight darkCorTile litCorTile dark fence qarea = do+  qFWall <- fromMaybe (error $ "" `showFailure` cwallTile)+            <$> opick cotile cwallTile (const True)+  qFCorner <- fromMaybe (error $ "" `showFailure` ccornerTile)+              <$> opick cotile ccornerTile (const True)+  let qFFloor = if dark then darkCorTile else litCorTile+      qFGround = if dnight then darkCorTile else litCorTile+  return $! case fence of+    FWall -> buildFenceMap qFWall qFCorner qarea+    FFloor -> buildFenceMap qFFloor qFFloor qarea+    FGround -> buildFenceMap qFGround qFGround qarea+    FNone -> EM.empty++-- | Construct a fence around an area, with the given tile kind.+-- Corners have a different kind, e.g., to avoid putting doors there.+buildFenceMap :: ContentId TileKind -> ContentId TileKind -> Area -> TileMapEM+buildFenceMap wallId cornerId area =+  let (x0, y0, x1, y1) = fromArea area+  in EM.fromList $ [ (Point x y, wallId)+                   | x <- [x0-1, x1+1], y <- [y0..y1] ] +++                   [ (Point x y, wallId)+                   | x <- [x0..x1], y <- [y0-1, y1+1] ] +++                   [ (Point x y, cornerId)+                   | x <- [x0-1, x1+1], y <- [y0-1, y1+1] ]++-- | Construct a fence around an area, with the given tile group.+buildFenceRnd :: COps+              -> GroupName TileKind -> GroupName TileKind+              -> GroupName TileKind -> GroupName TileKind+              -> Area+              -> Rnd TileMapEM+buildFenceRnd COps{cotile}+              cfenceTileN cfenceTileE cfenceTileS cfenceTileW area = do+  let (x0, y0, x1, y1) = fromArea area+      allTheSame = all (== cfenceTileN) [cfenceTileE, cfenceTileS, cfenceTileW]+      fenceIdRnd couterFenceTile (xf, yf) = do+        let isCorner x y = x `elem` [x0-1, x1+1] && y `elem` [y0-1, y1+1]+            tileGroup | isCorner xf yf && not allTheSame = TK.S_BASIC_OUTER_FENCE+                      | otherwise = couterFenceTile+        fenceId <- fromMaybe (error $ "" `showFailure` tileGroup)+                   <$> opick cotile tileGroup (const True)+        return (Point xf yf, fenceId)+      pointListN = [(x, y0-1) | x <- [x0-1..x1+1]]+      pointListE = [(x1+1, y) | y <- [y0..y1]]+      pointListS = [(x, y1+1) | x <- [x0-1..x1+1]]+      pointListW = [(x0-1, y) | y <- [y0..y1]]+  fenceListN <- mapM (fenceIdRnd cfenceTileN) pointListN+  fenceListE <- mapM (fenceIdRnd cfenceTileE) pointListE+  fenceListS <- mapM (fenceIdRnd cfenceTileS) pointListS+  fenceListW <- mapM (fenceIdRnd cfenceTileW) pointListW+  return $! EM.fromList $ fenceListN ++ fenceListE ++ fenceListS ++ fenceListW++-- | Create a place by tiling patterns.+tilePlace :: Area                           -- ^ the area to fill+          -> PlaceKind                      -- ^ the place kind to construct+          -> Rnd (EM.EnumMap Point Char)+tilePlace area pl@PlaceKind{..} = do+  let (Point x0 y0, xspan, yspan) = spanArea area+      dxcorner = case ptopLeft of+        [] -> error $ "" `showFailure` (area, pl)+        l : _ -> T.length l+      (dx, dy) = assert (xspan >= dxcorner && yspan >= length ptopLeft+                         `blame` (area, pl))+                        (xspan, yspan)+      fromX (x2, y2) = map (`Point` y2) [x2..]+      fillInterior :: (Int -> String -> String)+                   -> (Int -> [String] -> [String])+                   -> [(Point, Char)]+      fillInterior f g =+        let tileInterior (y, row) =+              let fx = f dx row+                  xStart = x0 + ((xspan - length fx) `div` 2)+              in filter ((/= 'X') . snd) $ zip (fromX (xStart, y)) fx+            reflected =+              let gy = g dy $ map T.unpack ptopLeft+                  yStart = y0 + ((yspan - length gy) `div` 2)+              in zip [yStart..] gy+        in concatMap tileInterior reflected+      tileReflect :: Int -> [a] -> [a]+      tileReflect d pat =+        let lstart = take (d `divUp` 2) pat+            lend   = take (d `div`   2) pat+        in lstart ++ reverse lend+  interior <- case pcover of+    CAlternate -> do+      let tile :: Int -> [a] -> [a]+          tile _ []  = error $ "nothing to tile" `showFailure` pl+          tile d pat = take d (cycle $ init pat ++ init (reverse pat))+      return $! fillInterior tile tile+    CStretch -> do+      let stretch :: Int -> [a] -> [a]+          stretch _ []  = error $ "nothing to stretch" `showFailure` pl+          stretch d pat = tileReflect d (pat ++ repeat (last pat))+      return $! fillInterior stretch stretch+    CReflect -> do+      let reflect :: Int -> [a] -> [a]+          reflect d pat = tileReflect d (cycle pat)+      return $! fillInterior reflect reflect+    CVerbatim -> return $! fillInterior (\ _ x -> x) (\ _ x -> x)+    CMirror -> do+      mirror1 <- oneOf [id, reverse]+      mirror2 <- oneOf [id, reverse]+      return $! fillInterior (\_ l -> mirror1 l) (\_ l -> mirror2 l)+  return $! EM.fromList interior
+ engine-src/Game/LambdaHack/Server/Fov.hs view
@@ -0,0 +1,378 @@+-- | Field Of View scanning.+--+-- See <https://github.com/LambdaHack/LambdaHack/wiki/Fov-and-los>+-- for discussion.+module Game.LambdaHack.Server.Fov+  ( -- * Perception cache+    FovValid(..), PerValidFid+  , PerReachable(..), CacheBeforeLucid(..), PerActor+  , PerceptionCache(..), PerCacheLid, PerCacheFid+    -- * Data used in FOV computation and cached to speed it up+  , FovShine(..), FovLucid(..), FovLucidLid+  , FovClear(..), FovClearLid, FovLit (..), FovLitLid+    -- * Operations+  , perceptionFromPTotal, perActorFromLevel, boundSightByCalm+  , totalFromPerActor, lucidFromLevel, perFidInDungeon+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , perceptionFromPTotalNoStash, cacheBeforeLucidFromActor, shineFromLevel+  , floorLightSources, lucidFromItems, litFromLevel+  , litInDungeon, clearFromLevel, clearInDungeon, lucidInDungeon+  , perLidFromFaction, perceptionCacheFromLevel+  , Matrix, fullscan+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Int (Int64)+import qualified Data.IntSet as IS+import           GHC.Exts (inline)++import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Server.FovDigital++-- * Perception cache types++data FovValid a =+    FovValid a+  | FovInvalid+  deriving (Show, Eq)++-- | Main perception validity map, for all factions.+--+-- The inner type is not a set, due to an unbenchmarked theory+-- that a constant shape map is faster.+type PerValidFid = EM.EnumMap FactionId (EM.EnumMap LevelId Bool)++-- | Visually reachable positions (light passes through them to the actor).+-- They need to be intersected with lucid positions to obtain visible positions.+newtype PerReachable = PerReachable {preachable :: ES.EnumSet Point}+  deriving (Show, Eq)++data CacheBeforeLucid = CacheBeforeLucid+  { creachable :: PerReachable+  , cnocto     :: PerVisible+  , csmell     :: PerSmelled+  }+  deriving (Show, Eq)++type PerActor = EM.EnumMap ActorId (FovValid CacheBeforeLucid)++-- We might cache even more effectively in terms of Enum{Set,Map} unions+-- if we recorded for each field how many actors see it (and how many+-- lights lit it). But this is complex and unions of EnumSets are cheaper+-- than the EnumMaps that would be required.+data PerceptionCache = PerceptionCache+  { ptotal   :: FovValid CacheBeforeLucid+  , perActor :: PerActor+  }+  deriving (Show, Eq)++-- | Server cache of perceptions of a single faction,+-- indexed by level identifier.+type PerCacheLid = EM.EnumMap LevelId PerceptionCache++-- | Server cache of perceptions, indexed by faction identifier.+type PerCacheFid = EM.EnumMap FactionId PerCacheLid++-- * Data used in FOV computation++-- | Map from level positions that currently hold item or actor(s) with shine+-- to the maximum of radiuses of the shining lights.+--+-- Note that floor and (many projectile) actors light on a single tile+-- should be additive for @FovShine@ to be incrementally updated.+--+-- @FovShine@ should not even be kept in @StateServer@, because it's cheap+-- to compute, compared to @FovLucid@ and invalidated almost as often+-- (not invalidated only by @UpdAlterTile@).+newtype FovShine = FovShine {fovShine :: EM.EnumMap Point Int}+  deriving (Show, Eq)++-- | Level positions with either ambient light or shining items or actors.+newtype FovLucid = FovLucid {fovLucid :: ES.EnumSet Point}+  deriving (Show, Eq)++type FovLucidLid = EM.EnumMap LevelId (FovValid FovLucid)++-- | Level positions that pass through light and vision.+newtype FovClear = FovClear {fovClear :: PointArray.Array Bool}+  deriving (Show, Eq)++type FovClearLid = EM.EnumMap LevelId FovClear++-- | Level positions with tiles that have ambient light.+newtype FovLit = FovLit {fovLit :: ES.EnumSet Point}+  deriving (Show, Eq)++type FovLitLid = EM.EnumMap LevelId FovLit++-- * Update of invalidated Fov data++-- | Compute positions visible (reachable and seen) by the party.+-- A position is lucid, if it's lit by an ambient light or by a weak, portable+-- light source, e.g,, carried by an actor. A reachable and lucid position+-- is visible. Additionally, positions directly adjacent to an actor are+-- assumed to be visible to him (through sound, touch, noctovision, whatever).+perceptionFromPTotal :: FactionId -> LevelId+                     -> FovLucid -> CacheBeforeLucid -> State+                     -> Perception+perceptionFromPTotal fid lidPer fovLucid ptotal s =+  let per = perceptionFromPTotalNoStash fovLucid ptotal+  in case gstash $ sfactionD s EM.! fid of+       Just (lid, pos) | lid == lidPer ->+         per {psight = (psight per) {pvisible = ES.insert pos+                                                $ pvisible (psight per)}}+       _ -> per++perceptionFromPTotalNoStash :: FovLucid -> CacheBeforeLucid -> Perception+perceptionFromPTotalNoStash FovLucid{fovLucid} ptotal =+  let nocto = pvisible $ cnocto ptotal+      reach = preachable $ creachable ptotal+      psight = PerVisible $ nocto `ES.union` (reach `ES.intersection` fovLucid)+      psmell = csmell ptotal+  in Perception{..}++perActorFromLevel :: PerActor -> (ActorId -> Actor)+                  -> ActorMaxSkills -> FovClear+                  -> PerActor+perActorFromLevel perActorOld getActorB actorMaxSkills fovClear =+  -- Dying actors included, to let them see their own demise.+  let f _ fv@FovValid{} = fv+      f aid FovInvalid =+        let actorMaxSk = actorMaxSkills EM.! aid+            b = getActorB aid+        in FovValid $ cacheBeforeLucidFromActor fovClear b actorMaxSk+  in EM.mapWithKey f perActorOld++boundSightByCalm :: Int -> Int64 -> Int+boundSightByCalm sight calm = min (fromEnum $ calm `div` xM 5) sight++-- | Compute positions reachable by the actor. Reachable are all fields+-- on a visually unblocked path from the actor position.+-- Also compute positions seen by noctovision and perceived by smell.+cacheBeforeLucidFromActor :: FovClear -> Actor -> Ability.Skills+                          -> CacheBeforeLucid+cacheBeforeLucidFromActor clearPs body actorMaxSk =+  let radius =+        boundSightByCalm (Ability.getSk Ability.SkSight actorMaxSk) (bcalm body)+      spectatorPos = bpos body+      creachable = PerReachable $ fullscan radius spectatorPos clearPs+      cnocto = PerVisible $ fullscan (Ability.getSk Ability.SkNocto actorMaxSk)+                                     spectatorPos+                                     clearPs+      smellRadius =+        if Ability.getSk Ability.SkSmell actorMaxSk >= 2 then 2 else 0+      csmell = PerSmelled $ fullscan smellRadius spectatorPos clearPs+  in CacheBeforeLucid{..}++totalFromPerActor :: PerActor -> CacheBeforeLucid+totalFromPerActor perActor =+  let fromValid = \case+        FovValid x -> x+        FovInvalid -> error $ "" `showFailure` perActor+      addCacheBeforeLucid x cbl1 =+        let cbl2 = fromValid x+        in CacheBeforeLucid+          { creachable = PerReachable+                         $ ES.union (preachable $ creachable cbl1)+                                    (preachable $ creachable cbl2)+          , cnocto = PerVisible+                     $ ES.union (pvisible $ cnocto cbl1)+                                (pvisible $ cnocto cbl2)+          , csmell = PerSmelled+                     $ ES.union (psmelled $ csmell cbl1)+                                (psmelled $ csmell cbl2)+          }+      emptyCacheBeforeLucid = CacheBeforeLucid+        { creachable = PerReachable ES.empty+        , cnocto = PerVisible ES.empty+        , csmell = PerSmelled ES.empty }+  in foldr addCacheBeforeLucid emptyCacheBeforeLucid $ EM.elems perActor++-- | Update lights on the level. This is needed every (even enemy)+-- actor move to show thrown torches.+-- We need to update lights even if cmd doesn't change any perception,+-- so that for next cmd that does, but doesn't change lights,+-- and operates on the same level, the lights are up to date.+-- We could make lights lazy to ensure no computation is wasted,+-- but it's rare that cmd changed them, but not the perception+-- (e.g., earthquake in an uninhabited corner of the active arena,+-- but the we'd probably want some feedback, at least sound).+lucidFromLevel :: FovClearLid -> FovLitLid -> State -> LevelId -> Level+               -> FovLucid+lucidFromLevel fovClearLid fovLitLid s lid lvl =+  let shine = shineFromLevel s lid lvl+      lucids = lucidFromItems (fovClearLid EM.! lid)+               $ EM.assocs $ fovShine shine+      litTiles = fovLitLid EM.! lid+  in FovLucid $ ES.unions $ fovLit litTiles : map fovLucid lucids++shineFromLevel :: State -> LevelId -> Level -> FovShine+shineFromLevel s lid lvl =+  -- Actors shine as if they were leaders, for speed and to prevent+  -- micromanagement by switching leader to see more.+  let actorLights =+        [ (bpos b, radius)+        | (aid, b) <- inline actorAssocs (const True) lid s+        , let radius = Ability.getSk Ability.SkShine $ getActorMaxSkills aid s+        , radius > 0 ]+      floorLights = floorLightSources (sdiscoAspect s) lvl+      allLights = floorLights ++ actorLights+      -- If there is light both on the floor and carried by actor+      -- (or several projectile actors), its radius is the maximum.+  in FovShine $ EM.fromListWith max allLights++floorLightSources :: DiscoveryAspect -> Level -> [(Point, Int)]+floorLightSources discoAspect lvl =+  -- Not enough oxygen to have more than one light lit on a given tile.+  -- Items obscuring or dousing off fire are not cumulative as well.+  let processIid (accLight, accDouse) (iid, _) =+        let shine = IA.getSkill Ability.SkShine $ discoAspect EM.! iid+        in case compare shine 0 of+          EQ -> (accLight, accDouse)+          GT -> (max shine accLight, accDouse)+          LT -> (accLight, min shine accDouse)+      processBag bag acc = foldl' processIid acc $ EM.assocs bag+  in [ (p, radius)+     | (p, bag) <- EM.assocs $ lfloor lvl  -- lembed are hidden+     , let (maxLight, maxDouse) = processBag bag (0, 0)+           radius = maxLight + maxDouse+     , radius > 0 ]++-- | Compute all dynamically lit positions on a level, whether lit by actors+-- or shining floor items. Note that an actor can be blind,+-- in which case he doesn't see his own light (but others,+-- from his or other factions, possibly do).+lucidFromItems :: FovClear -> [(Point, Int)] -> [FovLucid]+lucidFromItems clearPs allItems =+  let lucidPos (!p, !shine) = FovLucid $ fullscan shine p clearPs+  in map lucidPos allItems++-- * Computation of initial perception and caches++-- | Calculate the perception and its caches for the whole dungeon.+perFidInDungeon :: State -> ( FovLitLid, FovClearLid, FovLucidLid+                            , PerValidFid, PerCacheFid, PerFid)+perFidInDungeon s =+  let fovLitLid = litInDungeon s+      fovClearLid = clearInDungeon s+      fovLucidLid = lucidInDungeon fovClearLid fovLitLid s+      perValidLid = EM.map (const True) (sdungeon s)+      perValidFid = EM.map (const perValidLid) (sfactionD s)+      f fid _ = perLidFromFaction fovLucidLid fovClearLid fid s+      em = EM.mapWithKey f $ sfactionD s+  in ( fovLitLid, fovClearLid, fovLucidLid+     , perValidFid, EM.map snd em, EM.map fst em)++litFromLevel :: COps -> Level -> FovLit+litFromLevel COps{coTileSpeedup} Level{ltile} =+  let litSet p t set = if Tile.isLit coTileSpeedup t then p : set else set+  in FovLit $ ES.fromDistinctAscList $ PointArray.ifoldrA' litSet [] ltile++litInDungeon :: State -> FovLitLid+litInDungeon s = EM.map (litFromLevel (scops s)) $ sdungeon s++clearFromLevel :: COps -> Level -> FovClear+clearFromLevel COps{coTileSpeedup} Level{ltile} =+  FovClear $ PointArray.mapA (Tile.isClear coTileSpeedup) ltile++clearInDungeon :: State -> FovClearLid+clearInDungeon s = EM.map (clearFromLevel (scops s)) $ sdungeon s++lucidInDungeon :: FovClearLid -> FovLitLid -> State -> FovLucidLid+lucidInDungeon fovClearLid fovLitLid s =+  EM.mapWithKey+    (\lid lvl -> FovValid $ lucidFromLevel fovClearLid fovLitLid s lid lvl)+    $ sdungeon s++-- | Calculate perception of a faction.+perLidFromFaction :: FovLucidLid -> FovClearLid -> FactionId -> State+                  -> (PerLid, PerCacheLid)+perLidFromFaction fovLucidLid fovClearLid fid s =+  let em = EM.mapWithKey (\lid _ ->+                            perceptionCacheFromLevel fovClearLid fid lid s)+                         (sdungeon s)+      fovLucid lid = case EM.lookup lid fovLucidLid of+        Just (FovValid fl) -> fl+        _ -> error $ "" `showFailure` (lid, fovLucidLid)+      getValid (FovValid pc) = pc+      getValid FovInvalid = error $ "" `showFailure` fid+      per lid pc = perceptionFromPTotal+                     fid lid (fovLucid lid) (getValid (ptotal pc)) s+  in (EM.mapWithKey per em, em)++perceptionCacheFromLevel :: FovClearLid -> FactionId -> LevelId -> State+                         -> PerceptionCache+perceptionCacheFromLevel fovClearLid fid lid s =+  let fovClear = fovClearLid EM.! lid+      lvlBodies = inline actorAssocs (== fid) lid s+      f (aid, b) =+        -- Actors see and smell as if they were leaders, for speed+        -- and to prevent micromanagement by switching leader to see more.+        let actorMaxSk = getActorMaxSkills aid s+        in if Ability.getSk Ability.SkSight actorMaxSk <= 0+              && Ability.getSk Ability.SkNocto actorMaxSk <= 0+              && Ability.getSk Ability.SkSmell actorMaxSk <= 0+           then Nothing  -- dumb missile+           else Just (aid, FovValid+                           $ cacheBeforeLucidFromActor fovClear b actorMaxSk)+      lvlCaches = mapMaybe f lvlBodies+      perActor = EM.fromDistinctAscList lvlCaches+      total = totalFromPerActor perActor+  in PerceptionCache{ptotal = FovValid total, perActor}++-- * The actual Fov algorithm++type Matrix = (Int, Int, Int, Int)++-- | Perform a full scan for a given position. Returns the positions+-- that are currently in the field of view.+-- The actor's own position is considred in his field of view.+fullscan :: Int       -- ^ scanning radius+         -> Point     -- ^ position of the spectator+         -> FovClear  -- ^ the array with clear positions+         -> ES.EnumSet Point+fullscan !radius spectatorPos fc = case radius of+  2 -> squareUnsafeSet spectatorPos+  1 -> ES.singleton spectatorPos+  0 -> ES.empty  -- e.g., smell for non-smelling+  _ | radius <= 0 -> ES.empty+  _ ->+    let !FovClear{fovClear} = fc+        !spectatorI = fromEnum spectatorPos+        mapTr :: Matrix -> [PointI]+        mapTr m@(!_, !_, !_, !_) = scan (radius - 1) isClear (trV m)+        trV :: Matrix -> Bump -> PointI+        {-# INLINE trV #-}+        trV (x1, y1, x2, y2) B{..} =+          spectatorI + fromEnum (Vector (x1 * bx + y1 * by) (x2 * bx + y2 * by))+        isClear :: PointI -> Bool+        {-# INLINE isClear #-}+        isClear = PointArray.accessI fovClear+    in ES.intSetToEnumSet $ IS.fromList+       $ [spectatorI]+         ++ mapTr (1, 0, 0, -1)   -- quadrant I+         ++ mapTr (0, 1, 1, 0)    -- II (counter-clockwise)+         ++ mapTr (-1, 0, 0, 1)   -- III+         ++ mapTr (0, -1, -1, 0)  -- IV
+ engine-src/Game/LambdaHack/Server/FovDigital.hs view
@@ -0,0 +1,318 @@+-- | DFOV (Digital Field of View) implemented according to specification at <http://roguebasin.roguelikedevelopment.org/index.php?title=Digital_field_of_view_implementation>.+-- This fast version of the algorithm, based on PFOV, has AFAIK+-- never been described nor implemented before.+--+-- The map is processed in depth-first-search manner, that is, as soon+-- as we detect on obstacle we move away from the viewer up to the+-- FOV radius and then restart on the other side of the obstacle.+-- This has better cache behaviour than breadth-firsts-search,+-- where we would process all tiles equally distant from the viewer+-- in the same round, because then we'd need to keep the many convex hulls+-- and edges, not just a single set, and we'd potentially traverse all+-- of them each round.+module Game.LambdaHack.Server.FovDigital+  ( scan+    -- * Scanning coordinate system+  , Bump(..)+    -- * Assorted minor operations+#ifdef EXPOSE_INTERNAL+    -- * Current scan parameters+  , Distance, Progress+    -- * Geometry in system @Bump@+  , LineOrdering, Line(..), ConvexHull(..), CHull(..), Edge, EdgeInterval+    -- * Internal operations+  , steepestInHull, foldlCHull', addToHull, addToHullGo+  , createLine, steepness, intersect+  , _debugSteeper, _debugLine+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude hiding (intersect)++import Game.LambdaHack.Common.Point (PointI)++-- | Distance from the (0, 0) point where FOV originates.+type Distance = Int++-- | Progress along an arc with a constant distance from (0, 0).+type Progress = Int++-- | Rotated and translated coordinates of 2D points, so that the points fit+-- in a single quadrant area (e, g., quadrant I for Permissive FOV, hence both+-- coordinates positive; adjacent diagonal halves of quadrant I and II+-- for Digital FOV, hence y positive).+-- The special coordinates are written using the standard mathematical+-- coordinate setup, where quadrant I, with x and y positive,+-- is on the upper right.+data Bump = B+  { bx :: Int+  , by :: Int+  }+  deriving Show++-- | Two strict orderings of lines with a common point.+data LineOrdering = Steeper | Shallower++-- | Straight line between points.+data Line = Line Bump Bump+  deriving Show++-- | Convex hull represented as a non-empty list of points.+data ConvexHull = ConvexHull Bump CHull+  deriving Show++data CHull =+    CHNil+  | CHCons Bump CHull+  deriving Show++-- | An edge (comprising of a line and a convex hull) of the area to be scanned.+type Edge = (Line, ConvexHull)++-- | The contiguous area left to be scanned, delimited by edges.+type EdgeInterval = (Edge, Edge)++-- | Calculates the list of tiles visible from (0, 0) within the given+-- sight range.+scan :: Distance          -- ^ visiblity distance+     -> (PointI -> Bool)  -- ^ visually clear position predicate+     -> (Bump -> PointI)  -- ^ coordinate transformation+     -> [PointI]+{-# INLINE scan #-}+scan !r isClear tr =+#ifdef WITH_EXPENSIVE_ASSERTIONS+ assert (r > 0 `blame` r) $  -- not really expensive, but obfuscates Core+#endif+  -- The scanned area is a square, which is a sphere in the chessboard metric.+  dscan 1 ( (Line (B 1 0) (B (-r) r), ConvexHull (B 0 0) CHNil)+          , (Line (B 0 0) (B (r+1) r), ConvexHull (B 1 0) CHNil) )+ where+  dscan :: Distance -> EdgeInterval -> [PointI]+  {-# INLINE dscan #-}+  dscan !d ( (sl{-shallow line-}, sHull), (el{-steep line-}, eHull) ) =+    dgo d sl sHull el eHull++  -- Speed (mosty JS) and generally convincing GHC to unbox stuff.+  dgo :: Distance -> Line -> ConvexHull -> Line -> ConvexHull -> [PointI]+  dgo !d !sl sHull !el eHull =  -- @sHull@ and @eHull@ may be unused++    let !ps0 = let (n, k) = intersect sl d  -- minimal progress to consider+               in n `div` k+        !pe = let (n, k) = intersect el d   -- maximal progress to consider+                -- Corners obstruct view, so the steep line, constructed+                -- from corners, is itself not a part of the view,+                -- so if its intersection with the horizonstal line at distance+                -- @d@ is only at a corner, we choose the position leading+                -- to a smaller view.+              in -1 + n `divUp` k+        outside =+          if d < r+          then let !trBump = bump ps0+               in if isClear trBump+                  then trBump : mscanVisible sl sHull (ps0+1)  -- start visible+                  else trBump : mscanShadowed (ps0+1)    -- start in shadow+          else map bump [ps0..pe]++        bump :: Progress -> PointI+        bump !px = tr $ B px d++        -- We're in a visible interval.+        mscanVisible :: Line -> ConvexHull -> Progress -> [PointI]+        mscanVisible line hull = goVisible+         where+          goVisible :: Progress -> [PointI]+          goVisible !ps =+            if ps <= pe+            then let !trBump = bump ps+                 in if isClear trBump  -- not entering shadow+                    then trBump : goVisible (ps+1)+                    else let steepBump = B ps d+                             nep = steepestInHull Shallower steepBump hull+                             neLine = createLine nep steepBump+                             neHull = addToHull Shallower steepBump eHull+                         in trBump : dgo (d+1) line hull neLine neHull+                            ++ mscanShadowed (ps+1)+                              -- note how we recursively scan more and more+                              -- distant tiles, up to the FOV radius,+                              -- before starting to process the shadow+            else dgo (d+1) line hull el eHull  -- reached end, scan next row++        -- We're in a shadowed interval.+        mscanShadowed :: Progress -> [PointI]+        mscanShadowed !ps =+          if ps <= pe+          then let !trBump = bump ps+               in if not $ isClear trBump  -- not moving out of shadow+                  then trBump : mscanShadowed (ps+1)+                  else let shallowBump = B ps d+                           nsp = steepestInHull Steeper shallowBump eHull+                           nsLine = createLine nsp shallowBump+                           nsHull = addToHull Steeper shallowBump sHull+                       in trBump : mscanVisible nsLine nsHull (ps+1)+          else []  -- reached end while in shadow++    in+#ifdef WITH_EXPENSIVE_ASSERTIONS+      assert (r >= d && d >= 0 && pe >= ps0+              `blame` (r,d,sl,sHull,el,eHull,ps0,pe))+#endif+        outside++-- | Specialized implementation for speed in the inner loop. Not partial.+steepestInHull :: LineOrdering -> Bump -> ConvexHull -> Bump+{-# NOINLINE steepestInHull #-}+steepestInHull !lineOrdering !new (ConvexHull !b !ch) = foldlCHull' max' b ch+ where max' !x !y = if steepness lineOrdering new x y then x else y++-- | Standard @foldl'@ over @CHull@.+foldlCHull' :: (a -> Bump -> a) -> a -> CHull -> a+{-# INLINE foldlCHull' #-}+foldlCHull' f = fgo+ where fgo !z CHNil = z+       fgo z (CHCons b ch) = fgo (f z b) ch++-- | Extends a convex hull of bumps with a new bump. The new bump makes+-- some old bumps unnecessary, e.g. those that are joined with the new steep+-- bump with lines that are not shallower than any newer lines in the hull.+-- Removing such unnecessary bumps slightly speeds up computation+-- of 'steepestInHull'.+--+-- Recursion in @addToHullGo@ seems spurious, but it's called each time with+-- potentially different comparison predicate, so it's necessary.+addToHull :: LineOrdering  -- ^ the line ordering to use+          -> Bump          -- ^ a new bump to consider+          -> ConvexHull    -- ^ a convex hull of bumps represented as a list+          -> ConvexHull+{-# INLINE addToHull #-}+addToHull lineOrdering new (ConvexHull old ch) =+  ConvexHull new $ addToHullGo lineOrdering new $ CHCons old ch++-- This worker is needed to avoid Core returning a pair (new, result)+-- and also Bump-packing new (steepBump/shallowBump) twice, losing sharing.+addToHullGo :: LineOrdering -> Bump -> CHull -> CHull+{-# NOINLINE addToHullGo #-}+addToHullGo !lineOrdering !new = hgo+ where+  hgo :: CHull -> CHull+  hgo (CHCons a ch@(CHCons b _)) | not (steepness lineOrdering new b a) = hgo ch+  hgo ch = ch++-- | Create a line from two points.+--+-- Debug: check if well-defined.+createLine :: Bump -> Bump -> Line+{-# INLINE createLine #-}+createLine p1 p2 =+  let line = Line p1 p2+  in+#ifdef WITH_EXPENSIVE_ASSERTIONS+    assert (uncurry blame $ _debugLine line)+#endif+      line++-- | Strictly compare steepness of lines @(b1, bf)@ and @(b2, bf)@,+-- according to the @LineOrdering@ given. This is related to comparing+-- the slope (gradient, angle) of two lines, but simplified wrt signs+-- to work fast in this particular setup.+--+-- Debug: Verify that the results of 2 independent checks are equal.+steepness :: LineOrdering -> Bump -> Bump -> Bump -> Bool+{-# INLINE steepness #-}+steepness lineOrdering (B xf yf) (B x1 y1) (B x2 y2) =+  let y2x1 = (yf - y2) * (xf - x1)+      y1x2 = (yf - y1) * (xf - x2)+      res = case lineOrdering of+        Steeper -> y2x1 > y1x2+        Shallower -> y2x1 < y1x2+  in+#ifdef WITH_EXPENSIVE_ASSERTIONS+     assert (res == _debugSteeper lineOrdering (B xf yf) (B x1 y1) (B x2 y2))+#endif+       res++{- |+A pair @(a, b)@ such that @a@ divided by @b@ is the X coordinate+of the intersection of a given line and the horizontal line at distance+@d@ above the X axis.++Derivation of the formula:+The intersection point @(xt, yt)@ satisfies the following equalities:++> yt = d+> (yt - y) (xf - x) = (xt - x) (yf - y)++hence++> (yt - y) (xf - x) = (xt - x) (yf - y)+> (d - y) (xf - x) = (xt - x) (yf - y)+> (d - y) (xf - x) + x (yf - y) = xt (yf - y)+> xt = ((d - y) (xf - x) + x (yf - y)) / (yf - y)++General remarks:+The FOV agrees with physical properties of tiles as diamonds+and visibility from any point to any point. A diamond is denoted+by the left corner of its encompassing tile. Hero is at (0, 0).+Order of processing in the first quadrant rotated by 45 degrees is++> 45678+>  123+>   @++so the first processed diamond is at (-1, 1). The order is similar+as for the restrictive shadow casting algorithm and reversed wrt PFOV.+The fast moving line when scanning is called the shallow line,+and it's the one that delimits the view from the left, while the steep+line is on the right, opposite to PFOV. We start scanning from the left.++The 'PointI' ('Enum' representation of @Point@) coordinates are cartesian.+The 'Bump' coordinates are cartesian, translated so that+the hero is at (0, 0) and rotated so that he always+looks at the first (rotated 45 degrees) quadrant. The ('Progress', 'Distance')+cordinates coincide with the @Bump@ coordinates, unlike in PFOV.++Debug: check that the line fits in the upper half-plane.+-}+intersect :: Line -> Distance -> (Int, Int)+{-# INLINE intersect #-}+intersect (Line (B x y) (B xf yf)) d =+#ifdef WITH_EXPENSIVE_ASSERTIONS+  assert (allB (>= 0) [y, yf])+#endif+    ((d - y)*(xf - x) + x*(yf - y), yf - y)++-- | Debug functions for DFOV:++-- | Debug: calculate steepness for DFOV in another way and compare results.+_debugSteeper :: LineOrdering -> Bump -> Bump -> Bump -> Bool+{-# INLINE _debugSteeper #-}+_debugSteeper lineOrdering f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) =+  assert (allB (>= 0) [yf, y1, y2]) $+  let (n1, k1) = intersect (Line p1 f) 0+      (n2, k2) = intersect (Line p2 f) 0+      sign = case lineOrdering of+        Steeper -> GT+        Shallower -> LT+  in compare (k1 * n2) (n1 * k2) == sign++-- | Debug: check if a view border line for DFOV is legal.+_debugLine :: Line -> (Bool, String)+{-# INLINE _debugLine #-}+_debugLine line@(Line (B x1 y1) (B x2 y2))+  | not (allB (>= 0) [y1, y2]) =+      (False, "negative Y coordinates: " ++ show line)+  | y1 == y2 && x1 == x2 =+      (False, "ill-defined line: " ++ show line)+  | y1 == y2 =+      (False, "horizontal line: " ++ show line)+  | crossL0 =+      (False, "crosses the X axis below 0: " ++ show line)+  | crossG1 =+      (False, "crosses the X axis above 1: " ++ show line)+  | otherwise = (True, "")+ where+  (n, k)  = line `intersect` 0+  (q, r)  = if k == 0 then (0, 0) else n `divMod` k+  crossL0 = q < 0  -- q truncated toward negative infinity+  crossG1 = q >= 1 && (q > 1 || r /= 0)
+ engine-src/Game/LambdaHack/Server/HandleAtomicM.hs view
@@ -0,0 +1,400 @@+-- | Handle atomic commands on the server, after they are executed+-- to change server 'State' and before they are sent to clients.+module Game.LambdaHack.Server.HandleAtomicM+  ( cmdAtomicSemSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , validateFloor, validateFloorBag, levelOfStash+  , invalidateArenas, updateSclear, updateSlit+  , invalidateLucidLid, invalidateLucidAid+  , actorHasShine, itemAffectsShineRadius, itemAffectsPerRadius+  , addPerActor, addPerActorAny, deletePerActor, deletePerActorAny+  , invalidatePerActor, reconsiderPerActor, invalidatePerLid+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.Fov+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.State++-- | Effect of atomic actions on server state is calculated+-- with the global state from after the command is executed+-- (except where the supplied @oldState@ is used).+cmdAtomicSemSer :: MonadServer m => State -> UpdAtomic -> m ()+cmdAtomicSemSer oldState cmd = case cmd of+  UpdRegisterItems{} -> return ()+  UpdCreateActor aid b _ -> do+    actorMaxSkills <- getsState sactorMaxSkills+    when (actorHasShine actorMaxSkills aid) $ invalidateLucidLid $ blid b+    addPerActor aid b+  UpdDestroyActor aid b _ -> do+    let actorMaxSkillsOld = sactorMaxSkills oldState+    when (actorHasShine actorMaxSkillsOld aid) $ invalidateLucidLid $ blid b+    deletePerActor actorMaxSkillsOld aid b+    modifyServer $ \ser ->+      ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)+                                   (sactorTime ser)+          , strajTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)+                                  (strajTime ser)+          , strajPushedBy = EM.delete aid (strajPushedBy ser)+          , sactorAn = EM.delete aid (sactorAn ser)+          , sactorStasis = ES.delete aid (sactorStasis ser) }+  UpdCreateItem _ iid _ _ (CFloor lid _) -> validateFloor iid lid+  UpdCreateItem _ iid _ _ (CActor aid CStash) -> do+    lid <- levelOfStash aid+    validateFloor iid lid+  UpdCreateItem _ iid _ _ (CActor aid CGround) -> do+    lid <- getsState $ blid . getActorBody aid+    validateFloor iid lid+  UpdCreateItem _ iid _ _ (CActor aid _) -> do+    discoAspect <- getsState sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid) $+      invalidateLucidAid aid+    when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdCreateItem{} -> return ()+  UpdDestroyItem _ iid _ _ (CFloor lid _) -> validateFloor iid lid+  UpdDestroyItem _ iid _ _  (CActor aid CStash) -> do+    lid <- levelOfStash aid+    validateFloor iid lid+  UpdDestroyItem _ iid _ _ (CActor aid CGround) -> do+    lid <- getsState $ blid . getActorBody aid+    validateFloor iid lid+  UpdDestroyItem _ iid _ _ (CActor aid _) -> do+    discoAspect <- getsState sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid) $+      invalidateLucidAid aid+    when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdDestroyItem{} -> return ()+  UpdSpotActor aid b -> do+    -- On server, it does't affect aspects, but does affect lucid (Ascend).+    actorMaxSkills <- getsState sactorMaxSkills+    when (actorHasShine actorMaxSkills aid) $ invalidateLucidLid $ blid b+    addPerActor aid b+  UpdLoseActor aid b -> do+    -- On server, it does't affect aspects, but does affect lucid (Ascend).+    let actorMaxSkillsOld = sactorMaxSkills oldState+    when (actorHasShine actorMaxSkillsOld aid) $ invalidateLucidLid $ blid b+    deletePerActor actorMaxSkillsOld aid b+    modifyServer $ \ser ->+      ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)+                                   (sactorTime ser)+          , strajTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)+                                  (strajTime ser)+          , strajPushedBy = EM.delete aid (strajPushedBy ser)+          , sactorAn = EM.delete aid (sactorAn ser)+          , sactorStasis = ES.delete aid (sactorStasis ser) }+  UpdSpotItem _ iid _ (CFloor lid _) -> validateFloor iid lid+  UpdSpotItem _ iid _  (CActor aid CStash) -> do+    lid <- levelOfStash aid+    validateFloor iid lid+  UpdSpotItem _ iid _ (CActor aid CGround) -> do+    lid <- getsState $ blid . getActorBody aid+    validateFloor iid lid+  UpdSpotItem _ iid _ (CActor aid _) -> do+    discoAspect <- getsState sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid) $+      invalidateLucidAid aid+    when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdSpotItem{} -> return ()+  UpdLoseItem _ iid _ (CFloor lid _) -> validateFloor iid lid+  UpdLoseItem _ iid _ (CActor aid CStash) -> do+    lid <- levelOfStash aid+    validateFloor iid lid+  UpdLoseItem _ iid _ (CActor aid CGround) -> do+    lid <- getsState $ blid . getActorBody aid+    validateFloor iid lid+  UpdLoseItem _ iid _ (CActor aid _) -> do+    discoAspect <- getsState sdiscoAspect+    when (itemAffectsShineRadius discoAspect iid) $+      invalidateLucidAid aid+    when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid+  UpdLoseItem{} -> return ()+  UpdSpotItemBag _ (CFloor lid _) bag  -> validateFloorBag bag lid+  UpdSpotItemBag _ (CActor aid CStash) bag -> do+    lid <- levelOfStash aid+    validateFloorBag bag lid+  UpdSpotItemBag _ (CActor aid CGround) bag -> do+    lid <- getsState $ blid . getActorBody aid+    validateFloorBag bag lid+  UpdSpotItemBag _ (CActor aid _) bag -> do+    discoAspect <- getsState sdiscoAspect+    let iids = EM.keys bag+    when (any (itemAffectsShineRadius discoAspect) iids) $+      invalidateLucidAid aid+    when (any (itemAffectsPerRadius discoAspect) iids) $+      reconsiderPerActor aid+  UpdSpotItemBag{} -> return ()+  UpdLoseItemBag _ (CFloor lid _) bag -> validateFloorBag bag lid+  UpdLoseItemBag _ (CActor aid CStash) bag -> do+    lid <- levelOfStash aid+    validateFloorBag bag lid+  UpdLoseItemBag _ (CActor aid CGround) bag -> do+    lid <- levelOfStash aid+    validateFloorBag bag lid+  UpdLoseItemBag _ (CActor aid _) bag -> do+    discoAspect <- getsState sdiscoAspect+    let iids = EM.keys bag+    when (any (itemAffectsShineRadius discoAspect) iids) $+      invalidateLucidAid aid+    when (any (itemAffectsPerRadius discoAspect) iids) $+      reconsiderPerActor aid+  UpdLoseItemBag{} -> return ()+  UpdMoveActor aid _ _ -> do+    actorMaxSkills <- getsState sactorMaxSkills+    when (actorHasShine actorMaxSkills aid) $ invalidateLucidAid aid+    invalidatePerActor aid+  UpdWaitActor{} -> return ()+  UpdDisplaceActor aid1 aid2 -> do+    actorMaxSkills <- getsState sactorMaxSkills+    when (actorHasShine actorMaxSkills aid1+          || actorHasShine actorMaxSkills aid2) $+      invalidateLucidAid aid1  -- the same lid as aid2+    invalidatePerActor aid1+    invalidatePerActor aid2+  UpdMoveItem iid _k aid s1 s2 -> do+    let dummyVerbose = False+        dummyKit = quantSingle+    cmdAtomicSemSer oldState $+      UpdLoseItem dummyVerbose iid dummyKit (CActor aid s1)+    cmdAtomicSemSer oldState $+      UpdSpotItem dummyVerbose iid dummyKit (CActor aid s2)+  UpdRefillHP{} -> return ()+  UpdRefillCalm aid _ -> do+    actorMaxSk <- getsState $ getActorMaxSkills aid+    body <- getsState $ getActorBody aid+    let sight = Ability.getSk Ability.SkSight actorMaxSk+        oldBody = getActorBody aid oldState+        radiusOld = boundSightByCalm sight (bcalm oldBody)+        radiusNew = boundSightByCalm sight (bcalm body)+    when (radiusOld /= radiusNew) $ invalidatePerActor aid+  UpdTrajectory{} -> return ()+  UpdQuitFaction{} -> return ()+  UpdSpotStashFaction _ fid lid _ -> invalidatePerFidLid fid lid+  UpdLoseStashFaction _ fid lid _ -> invalidatePerFidLid fid lid+  UpdLeadFaction{} -> invalidateArenas+  UpdDiplFaction{} -> return ()+  UpdDoctrineFaction{} -> return ()+  UpdAutoFaction{} -> return ()+  UpdRecordKill{} -> invalidateArenas+  UpdAlterTile lid pos fromTile toTile -> do+    clearChanged <- updateSclear lid pos fromTile toTile+    litChanged <- updateSlit lid pos fromTile toTile+    when (clearChanged || litChanged) $ invalidateLucidLid lid+    when clearChanged $ invalidatePerLid lid+  UpdAlterExplorable{} -> return ()+  UpdAlterGold{} -> return ()+  UpdSearchTile{} -> return ()+  UpdHideTile{} -> return ()+  UpdSpotTile{} -> return ()+  UpdLoseTile{} -> return ()+  UpdSpotEntry{} -> return ()+  UpdLoseEntry{} -> return ()+  UpdAlterSmell{} -> return ()+  UpdSpotSmell{} -> return ()+  UpdLoseSmell{} -> return ()+  UpdTimeItem{} -> return ()+  UpdAgeGame{} -> return ()+  UpdUnAgeGame{} -> return ()+  UpdDiscover{} -> return ()+  UpdCover{} -> return ()+  UpdDiscoverKind{} -> return ()+  UpdCoverKind{} -> return ()+  UpdDiscoverAspect{} -> return ()+  UpdCoverAspect{} -> return ()+  UpdDiscoverServer{} -> return ()+  UpdCoverServer{} -> return ()+  UpdPerception{} -> return ()+  UpdRestart{} -> return ()+  UpdRestartServer{} -> return ()+  UpdResume{} -> return ()+  UpdResumeServer{} -> return ()+  UpdKillExit{} -> return ()+  UpdWriteSave{} -> return ()+  UpdHearFid{} -> return ()+  UpdMuteMessages{} -> return ()++validateFloor :: MonadServer m => ItemId -> LevelId -> m ()+validateFloor iid lid = do+  discoAspect <- getsState sdiscoAspect+  when (itemAffectsShineRadius discoAspect iid) $ invalidateLucidLid lid++validateFloorBag :: MonadServer m => ItemBag -> LevelId -> m ()+validateFloorBag bag lid = do+  discoAspect <- getsState sdiscoAspect+  let iids = EM.keys bag+  when (any (itemAffectsShineRadius discoAspect) iids) $+    invalidateLucidLid lid++levelOfStash :: MonadStateRead m => ActorId -> m LevelId+levelOfStash aid = do+  b <- getsState $ getActorBody aid+  mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+  case mstash of+    Just (lid, _) -> return lid+    Nothing -> error $ "" `showFailure` (aid, b)++invalidateArenas :: MonadServer m => m ()+invalidateArenas = modifyServer $ \ser -> ser {svalidArenas = False}++updateSclear :: MonadServer m+             => LevelId -> Point -> ContentId TileKind -> ContentId TileKind+             -> m Bool+updateSclear lid pos fromTile toTile = do+  COps{coTileSpeedup} <- getsState scops+  let fromClear = Tile.isClear coTileSpeedup fromTile+      toClear = Tile.isClear coTileSpeedup toTile+  if fromClear == toClear then return False else do+    let f FovClear{fovClear} =+          FovClear $ fovClear PointArray.// [(pos, toClear)]+    modifyServer $ \ser ->+      ser {sfovClearLid = EM.adjust f lid $ sfovClearLid ser}+    return True++updateSlit :: MonadServer m+           => LevelId -> Point -> ContentId TileKind -> ContentId TileKind+           -> m Bool+updateSlit lid pos fromTile toTile = do+  COps{coTileSpeedup} <- getsState scops+  let fromLit = Tile.isLit coTileSpeedup fromTile+      toLit = Tile.isLit coTileSpeedup toTile+  if fromLit == toLit then return False else do+    let f (FovLit set) =+          FovLit $ if toLit then ES.insert pos set else ES.delete pos set+    modifyServer $ \ser -> ser {sfovLitLid = EM.adjust f lid $ sfovLitLid ser}+    return True++invalidateLucidLid :: MonadServer m => LevelId -> m ()+invalidateLucidLid lid =+  modifyServer $ \ser ->+    ser { sfovLucidLid = EM.insert lid FovInvalid $ sfovLucidLid ser+        , sperValidFid = EM.map (EM.insert lid False) $ sperValidFid ser }++invalidateLucidAid :: MonadServer m => ActorId -> m ()+invalidateLucidAid aid = do+  lid <- getsState $ blid . getActorBody aid+  invalidateLucidLid lid++actorHasShine :: ActorMaxSkills -> ActorId -> Bool+actorHasShine actorMaxSkills aid = case EM.lookup aid actorMaxSkills of+  Just actorMaxSk -> Ability.getSk Ability.SkShine actorMaxSk > 0+  Nothing -> error $ "" `showFailure` aid++itemAffectsShineRadius :: DiscoveryAspect -> ItemId -> Bool+itemAffectsShineRadius discoAspect iid = case EM.lookup iid discoAspect of+  Just arItem -> IA.getSkill Ability.SkShine arItem /= 0+  Nothing -> error $ "" `showFailure` iid++itemAffectsPerRadius :: DiscoveryAspect -> ItemId -> Bool+itemAffectsPerRadius discoAspect iid =+  case EM.lookup iid discoAspect of+    Just arItem -> IA.getSkill Ability.SkSight arItem /= 0+               || IA.getSkill Ability.SkSmell arItem /= 0+               || IA.getSkill Ability.SkNocto arItem /= 0+    Nothing -> error $ "" `showFailure` iid++addPerActor :: MonadServer m => ActorId -> Actor -> m ()+addPerActor aid b = do+  actorMaxSk <- getsState $ getActorMaxSkills aid+  unless (Ability.getSk Ability.SkSight actorMaxSk <= 0+          && Ability.getSk Ability.SkNocto actorMaxSk <= 0+          && Ability.getSk Ability.SkSmell actorMaxSk <= 0) $+    addPerActorAny aid b++addPerActorAny :: MonadServer m => ActorId -> Actor -> m ()+addPerActorAny aid b = do+  let fid = bfid b+      lid = blid b+      f PerceptionCache{perActor} = PerceptionCache+        { ptotal = FovInvalid+        , perActor = EM.insert aid FovInvalid perActor }+  modifyServer $ \ser ->+    ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser+        , sperValidFid = EM.adjust (EM.insert lid False) fid+                         $ sperValidFid ser }++deletePerActor :: MonadServer m => ActorMaxSkills -> ActorId -> Actor -> m ()+deletePerActor actorMaxSkillsOld aid b = do+  let actorMaxSk = actorMaxSkillsOld EM.! aid+  unless (Ability.getSk Ability.SkSight actorMaxSk <= 0+          && Ability.getSk Ability.SkNocto actorMaxSk <= 0+          && Ability.getSk Ability.SkSmell actorMaxSk <= 0) $+    deletePerActorAny aid b++deletePerActorAny :: MonadServer m => ActorId -> Actor -> m ()+deletePerActorAny aid b = do+  let fid = bfid b+      lid = blid b+      f PerceptionCache{perActor} = PerceptionCache+        { ptotal = FovInvalid+        , perActor = EM.delete aid perActor }+  modifyServer $ \ser ->+    ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser+        , sperValidFid = EM.adjust (EM.insert lid False) fid+                         $ sperValidFid ser }++invalidatePerActor :: MonadServer m => ActorId -> m ()+invalidatePerActor aid = do+  actorMaxSk <- getsState $ getActorMaxSkills aid+  unless (Ability.getSk Ability.SkSight actorMaxSk <= 0+          && Ability.getSk Ability.SkNocto actorMaxSk <= 0+          && Ability.getSk Ability.SkSmell actorMaxSk <= 0) $ do+    b <- getsState $ getActorBody aid+    addPerActorAny aid b++reconsiderPerActor :: MonadServer m => ActorId -> m ()+reconsiderPerActor aid = do+  b <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  if Ability.getSk Ability.SkSight actorMaxSk <= 0+     && Ability.getSk Ability.SkNocto actorMaxSk <= 0+     && Ability.getSk Ability.SkSmell actorMaxSk <= 0+  then do+    perCacheFid <- getsServer sperCacheFid+    when (EM.member aid $ perActor ((perCacheFid EM.! bfid b) EM.! blid b)) $+      deletePerActorAny aid b+  else addPerActorAny aid b++invalidatePerLid :: MonadServer m => LevelId -> m ()+invalidatePerLid lid = do+  let f pc@PerceptionCache{perActor}+        | EM.null perActor = pc+        | otherwise = PerceptionCache+          { ptotal = FovInvalid+          , perActor = EM.map (const FovInvalid) perActor }+  modifyServer $ \ser ->+    let perCacheFidNew = EM.map (EM.adjust f lid) $ sperCacheFid ser+        g fid valid |+          ptotal ((perCacheFidNew EM.! fid) EM.! lid) == FovInvalid =+          EM.insert lid False valid+        g _ valid = valid+    in ser { sperCacheFid = perCacheFidNew+           , sperValidFid = EM.mapWithKey g $ sperValidFid ser }++invalidatePerFidLid :: MonadServer m => FactionId -> LevelId -> m ()+invalidatePerFidLid fid lid = do+  let adj = EM.insert lid False+  modifyServer $ \ser ->+    ser {sperValidFid = EM.adjust adj fid $ sperValidFid ser}
+ engine-src/Game/LambdaHack/Server/HandleEffectM.hs view
@@ -0,0 +1,2296 @@+{-# LANGUAGE TupleSections #-}+-- | Handle effects. They are most often caused by requests sent by clients+-- but sometimes also caused by projectiles or periodically activated items.+module Game.LambdaHack.Server.HandleEffectM+  ( UseResult(..), EffToUse(..), EffApplyFlags(..)+  , applyItem, cutCalm, kineticEffectAndDestroy, effectAndDestroyAndAddKill+  , itemEffectEmbedded, highestImpression, dominateFidSfx+  , dropAllEquippedItems, pickDroppable, consumeItems, dropCStoreItem+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , applyKineticDamage, refillHP, effectAndDestroy, imperishableKit+  , itemEffectDisco, effectSem+  , effectBurn, effectExplode, effectRefillHP, effectRefillCalm+  , effectDominate, dominateFid, effectImpress, effectPutToSleep, effectYell+  , effectSummon, effectAscend, findStairExit, switchLevels1, switchLevels2+  , effectEscape, effectParalyze, paralyze, effectParalyzeInWater+  , effectInsertMove, effectTeleport, effectCreateItem+  , effectDestroyItem, effectDropItem, effectConsumeItems+  , effectRecharge, effectPolyItem, effectRerollItem, effectDupItem+  , effectIdentify, identifyIid, effectDetect, effectDetectX, effectSendFlying+  , sendFlyingVector, effectApplyPerfume, effectAtMostOneOf, effectOneOf+  , effectAndEffect, effectAndEffectSem, effectOrEffect, effectSeqEffect+  , effectWhen, effectUnless, effectIfThenElse+  , effectVerbNoLonger, effectVerbMsg, effectVerbMsgFail+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Bits (xor)+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.HashMap.Strict as HM+import           Data.Int (Int64)+import           Data.Key (mapWithKeyM_)+import qualified Data.Text as T++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Analytics+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Definition.Ability (ActivationFlag (..))+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.CommonM+import           Game.LambdaHack.Server.ItemM+import           Game.LambdaHack.Server.ItemRev+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.PeriodicM+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++-- * Semantics of effects++data UseResult = UseDud | UseId | UseUp+  deriving (Eq, Ord)++data EffToUse = EffBare | EffBareAndOnCombine | EffOnCombine+  deriving Eq++data EffApplyFlags = EffApplyFlags+  { effToUse            :: EffToUse+  , effVoluntary        :: Bool+  , effUseAllCopies     :: Bool+  , effKineticPerformed :: Bool+  , effActivation       :: Ability.ActivationFlag+  , effMayDestroy       :: Bool+  }++applyItem :: MonadServerAtomic m => ActorId -> ItemId -> CStore -> m ()+applyItem aid iid cstore = do+  execSfxAtomic $ SfxApply aid iid+  let c = CActor aid cstore+  -- Treated as if the actor hit himself with the item as a weapon,+  -- incurring both the kinetic damage and effect, hence the same call+  -- as in @reqMelee@.+  let effApplyFlags = EffApplyFlags+        { effToUse            = EffBareAndOnCombine+        , effVoluntary        = True+        , effUseAllCopies     = False+        , effKineticPerformed = False+        , effActivation       = ActivationTrigger+        , effMayDestroy       = True+        }+  void $ kineticEffectAndDestroy effApplyFlags aid aid aid iid c++applyKineticDamage :: MonadServerAtomic m+                   => ActorId -> ActorId -> ItemId -> m Bool+applyKineticDamage source target iid = do+  itemKind <- getsState $ getIidKindServer iid+  if IK.idamage itemKind == 0 then return False else do  -- speedup+    sb <- getsState $ getActorBody source+    hurtMult <- getsState $ armorHurtBonus source target+    totalDepth <- getsState stotalDepth+    Level{ldepth} <- getLevel (blid sb)+    dmg <- rndToAction $ castDice ldepth totalDepth $ IK.idamage itemKind+    let rawDeltaHP = into @Int64 hurtMult * xM dmg `divUp` 100+        speedDeltaHP = case btrajectory sb of+          Just (_, speed) | bproj sb -> - modifyDamageBySpeed rawDeltaHP speed+          _ -> - rawDeltaHP+    if speedDeltaHP < 0 then do  -- damage the target, never heal+      refillHP source target speedDeltaHP+      return True+    else return False++refillHP :: MonadServerAtomic m => ActorId -> ActorId -> Int64 -> m ()+refillHP source target speedDeltaHP = assert (speedDeltaHP /= 0) $ do+  tbOld <- getsState $ getActorBody target+  actorMaxSk <- getsState $ getActorMaxSkills target+  -- We don't ignore even tiny HP drains, because they can be very weak+  -- enemy projectiles and so will recur and in total can be deadly+  -- and also AI should rather be stupidly aggressive than stupidly lethargic.+  let serious = source /= target && not (bproj tbOld)+      hpMax = Ability.getSk Ability.SkMaxHP actorMaxSk+      deltaHP0 | serious && speedDeltaHP < minusM =+                 -- If overfull, at least cut back to max, unless minor drain.+                 min speedDeltaHP (xM hpMax - bhp tbOld)+               | otherwise = speedDeltaHP+      deltaHP = if | deltaHP0 > 0 && bhp tbOld > xM 999 ->  -- UI limit+                     tenthM  -- avoid nop, to avoid loops+                   | deltaHP0 < 0 && bhp tbOld < - xM 999 ->+                     -tenthM+                   | otherwise -> deltaHP0+  execUpdAtomic $ UpdRefillHP target deltaHP+  when serious $ cutCalm target+  tb <- getsState $ getActorBody target+  fact <- getsState $ (EM.! bfid tb) . sfactionD+  when (not (bproj tb) && fhasPointman (gkind fact)) $+    -- If leader just lost all HP, change the leader early (not when destroying+    -- the actor), to let players rescue him, especially if he's slowed+    -- by the attackers.+    when (bhp tb <= 0 && bhp tbOld > 0) $ do+      -- If all other party members dying, leadership will switch+      -- to one of them, which seems questionable, but it's rare+      -- and the disruption servers to underline the dire circumstance.+      electLeader (bfid tb) (blid tb) target+      mleader <- getsState $ gleader . (EM.! bfid tb) . sfactionD+      -- If really nobody else in the party, make him the leader back again+      -- on the oft chance that he gets revived by a projectile, etc.+      when (isNothing mleader) $+        execUpdAtomic $ UpdLeadFaction (bfid tb) Nothing $ Just target++cutCalm :: MonadServerAtomic m => ActorId -> m ()+cutCalm target = do+  tb <- getsState $ getActorBody target+  actorMaxSk <- getsState $ getActorMaxSkills target+  let upperBound = if hpTooLow tb actorMaxSk+                   then 2  -- to trigger domination on next attack, etc.+                   else xM $ Ability.getSk Ability.SkMaxCalm actorMaxSk+      deltaCalm = min minusM2 (upperBound - bcalm tb)+  -- HP loss decreases Calm by at least @minusM2@ to avoid "hears something",+  -- which is emitted when decreasing Calm by @minusM1@.+  updateCalm target deltaCalm++-- Here kinetic damage is applied. This is necessary so that the same+-- AI benefit calculation may be used for flinging and for applying items.+kineticEffectAndDestroy :: MonadServerAtomic m+                        => EffApplyFlags+                        -> ActorId -> ActorId -> ActorId -> ItemId -> Container+                        -> m UseResult+kineticEffectAndDestroy effApplyFlags0@EffApplyFlags{..}+                        killer source target iid c = do+  bag <- getsState $ getContainerBag c+  case iid `EM.lookup` bag of+    Nothing -> error $ "" `showFailure` (source, target, iid, c)+    Just kit -> do+      itemFull <- getsState $ itemToFull iid+      tbOld <- getsState $ getActorBody target+      localTime <- getsState $ getLocalTime (blid tbOld)+      let recharged = hasCharge localTime kit+      -- If neither kinetic hit nor any effect is activated, there's no chance+      -- the items can be destroyed or even timeout changes, so we abort early.+      if not recharged then return UseDud else do+        effKineticPerformed2 <- applyKineticDamage source target iid+        tb <- getsState $ getActorBody target+        -- Sometimes victim heals just after we registered it as killed,+        -- but that's OK, an actor killed two times is similar enough+        -- to two killed.+        when (effKineticPerformed2  -- speedup+              && bhp tb <= 0 && bhp tbOld > 0) $ do+          sb <- getsState $ getActorBody source+          arWeapon <- getsState $ (EM.! iid) . sdiscoAspect+          let killHow | not (bproj sb) =+                        if effVoluntary+                        then KillKineticMelee+                        else KillKineticPush+                      | IA.checkFlag Ability.Blast arWeapon = KillKineticBlast+                      | otherwise = KillKineticRanged+          addKillToAnalytics killer killHow (bfid tbOld) (btrunk tbOld)+        let effApplyFlags = effApplyFlags0+              { effUseAllCopies     = fst kit <= 1+              , effKineticPerformed = effKineticPerformed2+              }+        effectAndDestroyAndAddKill effApplyFlags+                                   killer source target iid c itemFull++effectAndDestroyAndAddKill :: MonadServerAtomic m+                           => EffApplyFlags+                           -> ActorId -> ActorId -> ActorId -> ItemId+                           -> Container -> ItemFull+                           -> m UseResult+effectAndDestroyAndAddKill effApplyFlags0@EffApplyFlags{..}+                           killer source target iid c itemFull = do+  tbOld <- getsState $ getActorBody target+  triggered <- effectAndDestroy effApplyFlags0 source target iid c itemFull+  tb <- getsState $ getActorBody target+  -- Sometimes victim heals just after we registered it as killed,+  -- but that's OK, an actor killed two times is similar enough to two killed.+  when (bhp tb <= 0 && bhp tbOld > 0) $ do+    sb <- getsState $ getActorBody source+    arWeapon <- getsState $ (EM.! iid) . sdiscoAspect+    let killHow | not (bproj sb) =+                  if effVoluntary then KillOtherMelee else KillOtherPush+                | IA.checkFlag Ability.Blast arWeapon = KillOtherBlast+                | otherwise = KillOtherRanged+    addKillToAnalytics killer killHow (bfid tbOld) (btrunk tbOld)+  return triggered++effectAndDestroy :: MonadServerAtomic m+                 => EffApplyFlags+                 -> ActorId -> ActorId -> ItemId -> Container -> ItemFull+                 -> m UseResult+effectAndDestroy effApplyFlags0@EffApplyFlags{..} source target iid container+                 itemFull@ItemFull{itemDisco, itemKindId, itemKind} = do+  bag <- getsState $ getContainerBag container+  let (itemK, itemTimers) = bag EM.! iid+      effs = case effToUse of+        EffBare -> if effActivation == ActivationOnSmash+                   then IK.strengthOnSmash itemKind+                   else IK.ieffects itemKind+        EffBareAndOnCombine ->+          IK.ieffects itemKind ++ IK.strengthOnCombine itemKind+        EffOnCombine -> IK.strengthOnCombine itemKind+      arItem = case itemDisco of+        ItemDiscoFull itemAspect -> itemAspect+        _ -> error "effectAndDestroy: server ignorant about an item"+      timeout = IA.aTimeout arItem+  lid <- getsState $ lidFromC container+  localTime <- getsState $ getLocalTime lid+  let it1 = filter (charging localTime) itemTimers+      len = length it1+      recharged = len < itemK+                  || effActivation `elem` [ActivationOnSmash, ActivationConsume]+  -- If the item has no charges and the special cases don't apply+  -- we speed up by shortcutting early, because we don't need to activate+  -- effects and we know kinetic hit was not performed (no charges to do so+  -- and in case of @OnSmash@ and @ActivationConsume@,+  -- only effects are triggered).+  if not recharged then return UseDud else do+    let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout+        newItemTimer = createItemTimer localTime timeoutTurns+        it2 = if timeout > 0 && recharged+              then if effActivation == ActivationPeriodic+                      && IA.checkFlag Ability.Fragile arItem+                   then replicate (itemK - length it1) newItemTimer ++ it1+                           -- copies are spares only; one fires, all discharge+                   else take (itemK - length it1) [newItemTimer] ++ it1+                           -- copies all fire, turn by turn; <= 1 discharges+              else itemTimers+        kit2 = (1, take 1 it2)+        !_A = assert (len <= itemK `blame` (source, target, iid, container)) ()+    -- We use up the charge even if eventualy every effect fizzles. Tough luck.+    -- At least we don't destroy the item in such case.+    -- Also, we ID it regardless.+    unless (itemTimers == it2) $+      execUpdAtomic $ UpdTimeItem iid container itemTimers it2+    -- We have to destroy the item before the effect affects the item+    -- or affects the actor holding it or standing on it (later on we could+    -- lose track of the item and wouldn't be able to destroy it) .+    -- This is OK, because we don't remove the item type from various+    -- item dictionaries, just an individual copy from the container,+    -- so, e.g., the item can be identified after it's removed.+    let imperishable = not effMayDestroy+                       || imperishableKit effActivation itemFull+    unless imperishable $+      execUpdAtomic $ UpdLoseItem False iid kit2 container+    -- At this point, the item is potentially no longer in container+    -- @container@, therefore beware of assuming so in the code below.+    triggeredEffect <- itemEffectDisco effApplyFlags0 source target iid+                                       itemKindId itemKind container effs+    sb <- getsState $ getActorBody source+    let triggered = if effKineticPerformed then UseUp else triggeredEffect+        mEmbedPos = case container of+          CEmbed _ p -> Just p+          _ -> Nothing+    if | triggered == UseUp+         && mEmbedPos /= Just (bpos sb)  -- treading water, etc.+         && effActivation `notElem` [ActivationTrigger, ActivationMeleeable]+              -- do not repeat almost the same msg+         && (effActivation /= ActivationOnSmash  -- only tells condition ends+             && effActivation /= ActivationPeriodic+             || not (IA.checkFlag Ability.Condition arItem)) -> do+           -- Effects triggered; main feedback comes from them,+           -- but send info so that clients can log it.+           let verbose = effActivation == ActivationUnderRanged+                         || effActivation == ActivationUnderMelee+           execSfxAtomic $ SfxItemApplied verbose iid container+       | triggered /= UseUp+         && effActivation /= ActivationOnSmash+         && effActivation /= ActivationPeriodic+              -- periodic effects repeat and so spam+         && effActivation+            `notElem` [ActivationUnderRanged, ActivationUnderMelee]+              -- and so do effects under attack+         && not (bproj sb)  -- projectiles can be very numerous+         && isNothing mEmbedPos  ->  -- embeds may be just flavour+           -- Announce no effect, which is rare and wastes time, so noteworthy.+           execSfxAtomic $ SfxMsgFid (bfid sb) $+             if any IK.forApplyEffect effs+             then SfxFizzles iid container+                    -- something didn't work despite promising effects+             else SfxNothingHappens iid container  -- fully expected+       | otherwise -> return ()  -- all the spam cases+    -- If none of item's effects nor a kinetic hit were performed,+    -- we recreate the item (assuming we deleted the item above).+    -- Regardless, we don't rewind the time, because some info is gained+    -- (that the item does not exhibit any effects in the given context).+    unless (imperishable || triggered == UseUp) $+      execUpdAtomic $ UpdSpotItem False iid kit2 container+    return triggered++imperishableKit :: ActivationFlag -> ItemFull -> Bool+imperishableKit effActivation itemFull =+  let arItem = aspectRecordFull itemFull+  in IA.checkFlag Ability.Durable arItem+     || effActivation == ActivationPeriodic+        && not (IA.checkFlag Ability.Fragile arItem)++-- The item is triggered exactly once. If there are more copies,+-- they are left to be triggered next time.+-- If the embed no longer exists at the given position, effect fizzles.+itemEffectEmbedded :: MonadServerAtomic m+                   => EffToUse -> Bool -> ActorId -> LevelId -> Point -> ItemId+                   -> m UseResult+itemEffectEmbedded effToUse effVoluntary aid lid tpos iid = do+  embeds2 <- getsState $ getEmbedBag lid tpos+    -- might have changed due to other embedded items invocations+  if iid `EM.notMember` embeds2+  then return UseDud+  else do+    -- First embedded item may move actor to another level, so @lid@+    -- may be unequal to @blid sb@.+    let c = CEmbed lid tpos+    -- Treated as if the actor hit himself with the embedded item as a weapon,+    -- incurring both the kinetic damage and effect, hence the same call+    -- as in @reqMelee@. Information whether this happened due to being pushed+    -- is preserved, but how did the pushing is lost, so we blame the victim.+    let effApplyFlags = EffApplyFlags+          { effToUse+          , effVoluntary+          , effUseAllCopies     = False+          , effKineticPerformed = False+          , effActivation       = if effToUse == EffOnCombine+                                  then ActivationOnCombine+                                  else ActivationEmbed+          , effMayDestroy       = True+          }+    kineticEffectAndDestroy effApplyFlags aid aid aid iid c++-- | The source actor affects the target actor, with a given item.+-- If any of the effects fires up, the item gets identified.+-- Even using raw damage (beating the enemy with the magic wand,+-- for example) identifies the item. This means a costly @UpdDiscover@+-- is processed for each random timeout weapon hit and for most projectiles,+-- but at least not for most explosion particles nor plain organs.+-- And if not needed, the @UpdDiscover@ are eventually not sent to clients.+-- So, enemy missiles that hit us are no longer mysterious until picked up,+-- which is for the better, because the client knows their charging status+-- and so can generate accurate messages in the case when not recharged.+-- This also means that thrown consumables in flasks sturdy enough to cause+-- damage are always identified at hit, even if no effect activated.+-- So throwing them at foes is a better identification method than applying.+--+-- Note that if we activate a durable non-passive item, e.g., a spiked shield,+-- from the ground, it will get identified, which is perfectly fine,+-- until we want to add sticky armor that can't be easily taken off+-- (and, e.g., has some maluses).+itemEffectDisco :: MonadServerAtomic m+                => EffApplyFlags+                -> ActorId -> ActorId -> ItemId+                -> ContentId ItemKind -> ItemKind -> Container -> [IK.Effect]+                -> m UseResult+itemEffectDisco effApplyFlags0@EffApplyFlags{..}+                source target iid itemKindId itemKind c effs = do+  urs <- mapM (effectSem effApplyFlags0 source target iid c) effs+  let ur = case urs of+        [] -> UseDud  -- there was no effects+        _ -> maximum urs+  -- Note: @UseId@ suffices for identification, @UseUp@ is not necessary.+  when (ur >= UseId || effKineticPerformed) $+    identifyIid iid c itemKindId itemKind+  return ur++-- | Source actor affects target actor, with a given effect and it strength.+-- Both actors are on the current level and can be the same actor.+-- The item may or may not still be in the container.+effectSem :: MonadServerAtomic m+          => EffApplyFlags+          -> ActorId -> ActorId -> ItemId -> Container -> IK.Effect+          -> m UseResult+effectSem effApplyFlags0@EffApplyFlags{..}+          source target iid c effect = do+  let recursiveCall = effectSem effApplyFlags0 source target iid c+  sb <- getsState $ getActorBody source+  -- @execSfx@ usually comes last in effect semantics, but not always+  -- and we are likely to introduce more variety.+  let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target iid effect 0+      execSfxSource = execSfxAtomic $ SfxEffect (bfid sb) source iid effect 0+  case effect of+    IK.Burn nDm -> effectBurn nDm source target iid+    IK.Explode t -> effectExplode execSfx t source target c+    IK.RefillHP p -> effectRefillHP p source target iid+    IK.RefillCalm p -> effectRefillCalm execSfx p source target+    IK.Dominate -> effectDominate source target iid+    IK.Impress -> effectImpress recursiveCall execSfx source target+    IK.PutToSleep -> effectPutToSleep execSfx target+    IK.Yell -> effectYell execSfx target+    IK.Summon grp nDm -> effectSummon grp nDm iid source target effActivation+    IK.Ascend p -> effectAscend recursiveCall execSfx p source target c+    IK.Escape{} -> effectEscape execSfx source target+    IK.Paralyze nDm -> effectParalyze execSfx nDm source target+    IK.ParalyzeInWater nDm -> effectParalyzeInWater execSfx nDm source target+    IK.InsertMove nDm -> effectInsertMove execSfx nDm source target+    IK.Teleport nDm -> effectTeleport execSfx nDm source target+    IK.CreateItem mcount store grp tim ->+      effectCreateItem (Just $ bfid sb) mcount source target (Just iid)+                       store grp tim+    IK.DestroyItem n k store grp ->+      effectDestroyItem execSfx n k store target grp+    IK.ConsumeItems tools raw -> effectConsumeItems execSfx iid target tools raw+    IK.DropItem n k store grp -> effectDropItem execSfx iid n k store grp target+    IK.Recharge n dice -> effectRecharge True execSfx iid n dice target+    IK.Discharge n dice -> effectRecharge False execSfx iid n dice target+    IK.PolyItem -> effectPolyItem execSfx iid target+    IK.RerollItem -> effectRerollItem execSfx iid target+    IK.DupItem -> effectDupItem execSfx iid target+    IK.Identify -> effectIdentify execSfx iid target+    IK.Detect d radius -> effectDetect execSfx d radius target c+    IK.SendFlying tmod ->+      effectSendFlying execSfx tmod source target c Nothing+    IK.PushActor tmod ->+      effectSendFlying execSfx tmod source target c (Just True)+    IK.PullActor tmod ->+      effectSendFlying execSfx tmod source target c (Just False)+    IK.ApplyPerfume -> effectApplyPerfume execSfx target+    IK.AtMostOneOf l -> effectAtMostOneOf recursiveCall l+    IK.OneOf l -> effectOneOf recursiveCall l+    IK.OnSmash _ -> return UseDud  -- ignored under normal circumstances+    IK.OnCombine _ -> return UseDud  -- ignored under normal circumstances+    IK.OnUser eff -> effectSem effApplyFlags0 source source iid c eff+    IK.NopEffect -> return UseDud  -- all there is+    IK.AndEffect eff1 eff2 -> effectAndEffect recursiveCall source eff1 eff2+    IK.OrEffect eff1 eff2 -> effectOrEffect recursiveCall (bfid sb) eff1 eff2+    IK.SeqEffect effs -> effectSeqEffect recursiveCall effs+    IK.When cond eff ->+      effectWhen recursiveCall source cond eff effActivation+    IK.Unless cond eff ->+      effectUnless recursiveCall source cond eff effActivation+    IK.IfThenElse cond eff1 eff2 ->+      effectIfThenElse recursiveCall source cond eff1 eff2 effActivation+    IK.VerbNoLonger{} -> effectVerbNoLonger effUseAllCopies execSfxSource source+    IK.VerbMsg{} -> effectVerbMsg execSfxSource source+    IK.VerbMsgFail{} -> effectVerbMsgFail execSfxSource source++conditionSem :: MonadServer m+             => ActorId -> IK.Condition -> ActivationFlag -> m Bool+conditionSem source cond effActivation = do+  sb <- getsState $ getActorBody source+  return $! case cond of+    IK.HpLeq n -> bhp sb <= xM n+    IK.HpGeq n -> bhp sb >= xM n+    IK.CalmLeq n -> bcalm sb <= xM n+    IK.CalmGeq n -> bcalm sb >= xM n+    IK.TriggeredBy activationFlag -> activationFlag == effActivation++-- * Individual semantic functions for effects++-- ** Burn++-- Damage from fire. Not affected by armor.+effectBurn :: MonadServerAtomic m+           => Dice.Dice -> ActorId -> ActorId -> ItemId -> m UseResult+effectBurn nDm source target iid = do+  tb <- getsState $ getActorBody target+  totalDepth <- getsState stotalDepth+  Level{ldepth} <- getLevel (blid tb)+  n0 <- rndToAction $ castDice ldepth totalDepth nDm+  let n = max 1 n0  -- avoid 0 and negative burn; validated in content anyway+      deltaHP = - xM n+  sb <- getsState $ getActorBody source+  -- Display the effect more accurately.+  let reportedEffect = IK.Burn $ Dice.intToDice n+  execSfxAtomic $ SfxEffect (bfid sb) target iid reportedEffect deltaHP+  refillHP source target deltaHP+  return UseUp++-- ** Explode++effectExplode :: MonadServerAtomic m+              => m () -> GroupName ItemKind -> ActorId -> ActorId -> Container+              -> m UseResult+effectExplode execSfx cgroup source target containerOrigin = do+  execSfx+  tb <- getsState $ getActorBody target+  oxy@(Point x y) <- getsState $ posFromC containerOrigin+  let itemFreq = [(cgroup, 1)]+      -- Explosion particles are placed among organs of the victim.+      -- TODO: when changing this code, perhaps use @containerOrigin@+      -- in place of @container@, but then remove @borgan@ from several+      -- functions that have the store hardwired.+      container = CActor target COrgan+  -- Power depth of new items unaffected by number of spawned actors.+  Level{ldepth} <- getLevel $ blid tb+  freq <- prepareItemKind 0 ldepth itemFreq+  m2 <- rollAndRegisterItem False ldepth freq container Nothing+  acounter <- getsServer $ fromEnum . sacounter+  let (iid, (ItemFull{itemKind}, (itemK, _))) =+        fromMaybe (error $ "" `showFailure` cgroup) m2+      semiRandom = T.length (IK.idesc itemKind)+      -- We pick a point at the border, not inside, to have a uniform+      -- distribution for the points the line goes through at each distance+      -- from the source. Otherwise, e.g., the points on cardinal+      -- and diagonal lines from the source would be more common.+      projectN k10 n = do+        -- Shape is deterministic for the explosion kind, except that is has+        -- two variants chosen according to time-dependent @veryRandom@.+        -- Choice from the variants prevents diagonal or cardinal directions+        -- being always safe for a given explosion kind.+        let shapeRandom = k10 `xor` (semiRandom + n)+            veryRandom = shapeRandom + acounter + acounter `div` 3+            fuzz = 5 + shapeRandom `mod` 5+            k | n < 16 && n >= 12 = 12+              | n < 12 && n >= 8 = 8+              | n < 8 && n >= 4 = 4+              | otherwise = min n 16  -- fire in groups of 16 including old duds+            psDir4 =+              [ Point (x - 12) (y + 12)+              , Point (x + 12) (y + 12)+              , Point (x - 12) (y - 12)+              , Point (x + 12) (y - 12) ]+            psDir8 =+              [ Point (x - 12) y+              , Point (x + 12) y+              , Point x (y + 12)+              , Point x (y - 12) ]+            psFuzz =+              [ Point (x - 12) $ y + fuzz+              , Point (x + 12) $ y + fuzz+              , Point (x - 12) $ y - fuzz+              , Point (x + 12) $ y - fuzz+              , flip Point (y - 12) $ x + fuzz+              , flip Point (y + 12) $ x + fuzz+              , flip Point (y - 12) $ x - fuzz+              , flip Point (y + 12) $ x - fuzz ]+            randomReverse = if even veryRandom then id else reverse+            ps = take k $ concat $+              randomReverse+                [ zip (repeat True)  -- diagonal particles don't reach that far+                  $ take 4 (drop ((k10 + itemK + fuzz) `mod` 4) $ cycle psDir4)+                , zip (repeat False)  -- only some cardinal reach far+                  $ take 4 (drop ((k10 + n) `mod` 4) $ cycle psDir8) ]+              ++ [zip (repeat True)+                  $ take 8 (drop ((k10 + fuzz) `mod` 8) $ cycle psFuzz)]+        forM_ ps $ \(centerRaw, tpxy) -> do+          let center = centerRaw && itemK >= 8  -- if few, keep them regular+          mfail <- projectFail source target oxy tpxy shapeRandom center+                               iid COrgan True+          case mfail of+            Nothing -> return ()+            Just ProjectBlockTerrain -> return ()+            Just ProjectBlockActor -> return ()+            Just failMsg ->+              execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxUnexpected failMsg+      tryFlying 0 = return ()+      tryFlying k10 = do+        -- Explosion particles were placed among organs of the victim:+        bag2 <- getsState $ borgan . getActorBody target+        -- We stop bouncing old particles when less than two thirds remain,+        -- to prevent hoarding explosives to use only in cramped spaces.+        case EM.lookup iid bag2 of+          Just (n2, _) | n2 * 2 >= itemK `div` 3 -> do+            projectN k10 n2+            tryFlying $ k10 - 1+          _ -> return ()+  -- Some of the particles that fail to take off, bounce off obstacles+  -- up to 10 times in total, trying to fly in different directions.+  tryFlying 10+  bag3 <- getsState $ borgan . getActorBody target+  let mn3 = EM.lookup iid bag3+  -- Give up and destroy the remaining particles, if any.+  maybe (return ()) (\kit -> execUpdAtomic+                             $ UpdLoseItem False iid kit container) mn3+  return UseUp  -- we neglect verifying that at least one projectile got off++-- ** RefillHP++-- Unaffected by armor.+effectRefillHP :: MonadServerAtomic m+               => Int -> ActorId -> ActorId -> ItemId -> m UseResult+effectRefillHP power0 source target iid = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  curChalSer <- getsServer $ scurChalSer . soptions+  fact <- getsState $ (EM.! bfid tb) . sfactionD+  let power = if power0 <= -1 then power0 else max 1 power0  -- avoid 0+      deltaHP = xM power+  if cfish curChalSer && deltaHP > 0+     && fhasUI (gkind fact) && bfid sb /= bfid tb+  then do+     execSfxAtomic $ SfxMsgFid (bfid tb) SfxColdFish+     return UseId+  else do+    let reportedEffect = IK.RefillHP power+    execSfxAtomic $ SfxEffect (bfid sb) target iid reportedEffect deltaHP+    refillHP source target deltaHP+    return UseUp++-- ** RefillCalm++effectRefillCalm :: MonadServerAtomic m+                 => m () -> Int -> ActorId -> ActorId -> m UseResult+effectRefillCalm execSfx power0 source target = do+  tb <- getsState $ getActorBody target+  actorMaxSk <- getsState $ getActorMaxSkills target+  let power = if power0 <= -1 then power0 else max 1 power0  -- avoid 0+      rawDeltaCalm = xM power+      calmMax = Ability.getSk Ability.SkMaxCalm actorMaxSk+      serious = rawDeltaCalm <= minusM2 && source /= target && not (bproj tb)+      deltaCalm0 | serious =  -- if overfull, at least cut back to max+                     min rawDeltaCalm (xM calmMax - bcalm tb)+                 | otherwise = rawDeltaCalm+      deltaCalm = if | deltaCalm0 > 0 && bcalm tb > xM 999 ->  -- UI limit+                       tenthM  -- avoid nop, to avoid loops+                     | deltaCalm0 < 0 && bcalm tb < - xM 999 ->+                       -tenthM+                     | otherwise -> deltaCalm0+  execSfx+  updateCalm target deltaCalm+  return UseUp++-- ** Dominate++-- The is another way to trigger domination (the normal way is by zeroed Calm).+-- Calm is here irrelevant. The other conditions are the same.+effectDominate :: MonadServerAtomic m+               => ActorId -> ActorId -> ItemId -> m UseResult+effectDominate source target iid = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  if | bproj tb -> return UseDud+     | bfid tb == bfid sb -> return UseDud  -- accidental hit; ignore+     | otherwise -> do+       fact <- getsState $ (EM.! bfid tb) . sfactionD+       hiImpression <- highestImpression tb+       let permitted = case hiImpression of+             Nothing -> False  -- no impression, no domination+             Just (hiImpressionFid, hiImpressionK) ->+                hiImpressionFid == bfid sb+                  -- highest impression needs to be by us+                && (fhasPointman (gkind fact) || hiImpressionK >= 10)+                     -- to tame/hack animal/robot, impress them a lot first+       if permitted then do+         b <- dominateFidSfx source target iid (bfid sb)+         return $! if b then UseUp else UseDud+       else do+         execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxUnimpressed target+         when (source /= target) $+           execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxUnimpressed target+         return UseDud++highestImpression :: MonadServerAtomic m+                  => Actor -> m (Maybe (FactionId, Int))+highestImpression tb = do+  getKind <- getsState $ flip getIidKindServer+  getItem <- getsState $ flip getItemBody+  let isImpression iid =+        maybe False (> 0) $ lookup IK.S_IMPRESSED $ IK.ifreq $ getKind iid+      impressions = EM.filterWithKey (\iid _ -> isImpression iid) $ borgan tb+      f (_, (k, _)) = k+      maxImpression = maximumBy (comparing f) $ EM.assocs impressions+  if EM.null impressions+  then return Nothing+  else case jfid $ getItem $ fst maxImpression of+    Nothing -> return Nothing+    Just fid -> assert (fid /= bfid tb)+                $ return $ Just (fid, fst $ snd maxImpression)++dominateFidSfx :: MonadServerAtomic m+               => ActorId ->  ActorId -> ItemId -> FactionId -> m Bool+dominateFidSfx source target iid fid = do+  tb <- getsState $ getActorBody target+  let !_A = assert (not $ bproj tb) ()+  -- Actors that don't move freely can't be dominated, for otherwise,+  -- when they are the last survivors, they could get stuck and the game+  -- wouldn't end. Also, they are a hassle to guide through the dungeon.+  canTra <- getsState $ canTraverse target+  -- Being pushed protects from domination, for simplicity.+  -- A possible interesting exploit, but much help from content would be needed+  -- to make it practical.+  if isNothing (btrajectory tb) && canTra && bhp tb > 0 then do+    let execSfx = execSfxAtomic $ SfxEffect fid target iid IK.Dominate 0+    execSfx  -- if actor ours, possibly the last occasion to see him+    dominateFid fid source target+    -- If domination resulted in game over, the message won't be seen+    -- before the end game screens, but at least it will be seen afterwards+    -- and browsable in history while inside subsequent game, revealing+    -- the cause of the previous game over. Better than no message at all.+    execSfx  -- see the actor as theirs, unless position not visible+    return True+  else+    return False++dominateFid :: MonadServerAtomic m => FactionId -> ActorId -> ActorId -> m ()+dominateFid fid source target = do+  tb0 <- getsState $ getActorBody target+  -- Game over deduced very early, so no further animation nor message+  -- will appear before game end screens. This is good in that our last actor+  -- that yielded will still be on screen when end game messages roll.+  -- This is bad in that last enemy actor that got dominated by us+  -- may not be on screen and we have no clue how we won until+  -- we see history in the next game. Even worse if our ally dominated+  -- the enemy actor. Then we may never learn. Oh well, that's realism.+  deduceKilled target+  electLeader (bfid tb0) (blid tb0) target+  -- Drop all items so that domiation is not too nasty, especially+  -- if the dominated hero runs off or teleports away with gold+  -- or starts hitting with the most potent artifact weapon in the game.+  -- Drop items while still of the original faction+  -- to mark them on the map for other party members to collect.+  dropAllEquippedItems target tb0+  tb <- getsState $ getActorBody target+  actorMaxSk <- getsState $ getActorMaxSkills target+  getKind <- getsState $ flip getIidKindServer+  let isImpression iid =+        maybe False (> 0) $ lookup IK.S_IMPRESSED $ IK.ifreq $ getKind iid+      dropAllImpressions = EM.filterWithKey (\iid _ -> not $ isImpression iid)+      borganNoImpression = dropAllImpressions $ borgan tb+  -- Actor is not pushed nor projectile, so @sactorTime@ suffices.+  btime <- getsServer+           $ fromJust . lookupActorTime (bfid tb) (blid tb) target . sactorTime+  execUpdAtomic $ UpdLoseActor target tb+  let maxCalm = Ability.getSk Ability.SkMaxCalm actorMaxSk+      maxHp = Ability.getSk Ability.SkMaxHP actorMaxSk+      bNew = tb { bfid = fid+                , bcalm = max (xM 10) $ xM maxCalm `div` 2+                , bhp = min (xM maxHp) $ bhp tb + xM 10+                , borgan = borganNoImpression}+  modifyServer $ \ser ->+    ser {sactorTime = updateActorTime fid (blid tb) target btime+                      $ sactorTime ser}+  execUpdAtomic $ UpdSpotActor target bNew+  -- Focus on the dominated actor, by making him a leader.+  setFreshLeader fid target+  factionD <- getsState sfactionD+  let inGame fact2 = case gquit fact2 of+        Nothing -> True+        Just Status{stOutcome=Camping} -> True+        _ -> False+      gameOver = not $ any inGame $ EM.elems factionD+  -- Avoid the spam of identifying items, if game over.+  unless gameOver $ do+    -- Add some nostalgia for the old faction.+    void $ effectCreateItem (Just $ bfid tb) (Just 10) source target Nothing+                            COrgan IK.S_IMPRESSED IK.timerNone+    -- Identify organs that won't get identified by use.+    getKindId <- getsState $ flip getIidKindIdServer+    let discoverIf (iid, cstore) = do+          let itemKindId = getKindId iid+              c = CActor target cstore+          assert (cstore /= CGround) $+            discoverIfMinorEffects c iid itemKindId+        aic = (btrunk tb, COrgan)+              : filter ((/= btrunk tb) . fst) (getCarriedIidCStore tb)+    mapM_ discoverIf aic++-- | Drop all actor's equipped items.+dropAllEquippedItems :: MonadServerAtomic m => ActorId -> Actor -> m ()+dropAllEquippedItems aid b =+  mapActorCStore_ CEqp+                  (void <$$> dropCStoreItem False False CEqp aid b maxBound)+                  b++-- ** Impress++effectImpress :: MonadServerAtomic m+              => (IK.Effect -> m UseResult) -> m () -> ActorId -> ActorId+              -> m UseResult+effectImpress recursiveCall execSfx source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  if | bproj tb -> return UseDud+     | bfid tb == bfid sb ->+       -- Unimpress wrt others, but only once. The recursive Sfx suffices.+       recursiveCall $ IK.DropItem 1 1 COrgan IK.S_IMPRESSED+     | otherwise -> do+       -- Actors that don't move freely and so are stupid, can't be impressed.+       canTra <- getsState $ canTraverse target+       if canTra then do+         unless (bhp tb <= 0)+           execSfx  -- avoid spam just before death+         effectCreateItem (Just $ bfid sb) (Just 1) source target Nothing COrgan+                          IK.S_IMPRESSED IK.timerNone+       else return UseDud  -- no message, because common and not crucial++-- ** PutToSleep++effectPutToSleep :: MonadServerAtomic m => m () -> ActorId -> m UseResult+effectPutToSleep execSfx target = do+  tb <- getsState $ getActorBody target+  if | bproj tb -> return UseDud+     | bwatch tb `elem` [WSleep, WWake] ->+         return UseDud  -- can't increase sleep+     | otherwise -> do+       actorMaxSk <- getsState $ getActorMaxSkills target+       if not $ canSleep actorMaxSk then+         return UseId  -- no message about the cause, so at least ID+       else do+         let maxCalm = xM $ Ability.getSk Ability.SkMaxCalm actorMaxSk+             deltaCalm = maxCalm - bcalm tb+         when (deltaCalm > 0) $+           updateCalm target deltaCalm  -- max Calm, but asleep vulnerability+         execSfx+         case bwatch tb of+           WWait n | n > 0 -> do+             nAll <- removeConditionSingle IK.S_BRACED target+             let !_A = assert (nAll == 0) ()+             return ()+           _ -> return ()+         -- Forced sleep. No check if the actor can sleep naturally.+         addSleep target+         return UseUp++-- ** Yell++-- This is similar to 'reqYell', but also mentions that the actor is startled,+-- because, presumably, he yells involuntarily. It doesn't wake him up+-- via Calm instantly, just like yelling in a dream not always does.+effectYell :: MonadServerAtomic m => m () -> ActorId -> m UseResult+effectYell execSfx target = do+  tb <- getsState $ getActorBody target+  if bhp tb <= 0 then  -- avoid yelling corpses+    return UseDud  -- the yell never manifested+  else do+    unless (bproj tb)+      execSfx+    execSfxAtomic $ SfxTaunt False target+    when (not (bproj tb) && deltaBenign (bcalmDelta tb)) $+      execUpdAtomic $ UpdRefillCalm target minusM+    return UseUp++-- ** Summon++-- Note that the Calm expended doesn't depend on the number of actors summoned.+effectSummon :: MonadServerAtomic m+             => GroupName ItemKind -> Dice.Dice -> ItemId+             -> ActorId -> ActorId -> ActivationFlag+             -> m UseResult+effectSummon grp nDm iid source target effActivation = do+  -- Obvious effect, nothing announced.+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  sMaxSk <- getsState $ getActorMaxSkills source+  tMaxSk <- getsState $ getActorMaxSkills target+  totalDepth <- getsState stotalDepth+  Level{ldepth, lbig} <- getLevel (blid tb)+  nFriends <- getsState $ length . friendRegularAssocs (bfid sb) (blid sb)+  discoAspect <- getsState sdiscoAspect+  power0 <- rndToAction $ castDice ldepth totalDepth nDm+  fact <- getsState $ (EM.! bfid sb) . sfactionD+  let arItem = discoAspect EM.! iid+      power = max power0 1  -- KISS, always at least one summon+      -- We put @source@ instead of @target@ and @power@ instead of dice+      -- to make the message more accurate.+      effect = IK.Summon grp $ Dice.intToDice power+      durable = IA.checkFlag Ability.Durable arItem+      warnBothActors warning =+       unless (bproj sb) $ do+         execSfxAtomic $ SfxMsgFid (bfid sb) warning+         when (source /= target) $+           execSfxAtomic $ SfxMsgFid (bfid tb) warning+      deltaCalm = - xM 30+  -- Verify Calm only at periodic activations or if the item is durable.+  -- Otherwise summon uses up the item, which prevents summoning getting+  -- out of hand. I don't verify Calm otherwise, to prevent an exploit+  -- via draining one's calm on purpose when an item with good activation+  -- has a nasty summoning side-effect (the exploit still works on durables).+  if | bproj tb+       || source /= target && not (isFoe (bfid sb) fact (bfid tb)) ->+       return UseDud  -- hitting friends or projectiles to summon is too cheap+     | (effActivation == ActivationPeriodic || durable) && not (bproj sb)+       && (bcalm sb < - deltaCalm || not (calmEnough sb sMaxSk)) -> do+       warnBothActors $ SfxSummonLackCalm source+       return UseId+     | nFriends >= 20 -> do+       -- We assume the actor tries to summon his teammates or allies.+       -- As he repeats such summoning, he is going to bump into this limit.+       -- If he summons others, see the next condition.+       warnBothActors $ SfxSummonTooManyOwn source+       return UseId+     | EM.size lbig >= 200 -> do  -- lower than the 300 limit for spawning+       -- Even if the actor summons foes, he is prevented from exploiting it+       -- too many times and stopping natural monster spawning on the level+       -- (e.g., by filling the level with harmless foes).+       warnBothActors $ SfxSummonTooManyAll source+       return UseId+     | otherwise -> do+       unless (bproj sb) $ updateCalm source deltaCalm+       localTime <- getsState $ getLocalTime (blid tb)+       -- Make sure summoned actors start acting after the victim.+       let actorTurn = ticksPerMeter $ gearSpeed tMaxSk+           targetTime = timeShift localTime actorTurn+           afterTime = timeShift targetTime $ Delta timeClip+       -- Mark as summoned to prevent immediate chain summoning.+       -- Summon from current depth, not deeper due to many spawns already.+       anySummoned <- addManyActors True 0 [(grp, 1)] (blid tb) afterTime+                                    (Just $ bpos tb) power+       if anySummoned then do+         execSfxAtomic $ SfxEffect (bfid sb) source iid effect 0+         return UseUp+       else do+         -- We don't display detailed warnings when @addAnyActor@ fails,+         -- e.g., because the actor groups can't be generated on a given level.+         -- However, we at least don't claim any summoning happened+         -- and we offer a general summoning failure messages.+         warnBothActors $ SfxSummonFailure source+         return UseId++-- ** Ascend++-- Note that projectiles can be teleported, too, for extra fun.+effectAscend :: MonadServerAtomic m+             => (IK.Effect -> m UseResult)+             -> m () -> Bool -> ActorId -> ActorId -> Container+             -> m UseResult+effectAscend recursiveCall execSfx up source target container = do+  b1 <- getsState $ getActorBody target+  pos <- getsState $ posFromC container+  let lid1 = blid b1+  destinations <- getsState $ whereTo lid1 pos up . sdungeon+  sb <- getsState $ getActorBody source+  actorMaxSk <- getsState $ getActorMaxSkills target+  if | source /= target && Ability.getSk Ability.SkMove actorMaxSk <= 0 -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible+       when (source /= target) $+         execSfxAtomic $ SfxMsgFid (bfid b1) SfxTransImpossible+       return UseId+     | actorWaits b1 && source /= target -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target+       when (source /= target) $+         execSfxAtomic $ SfxMsgFid (bfid b1) $ SfxBracedImmune target+       return UseId+     | null destinations -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxLevelNoMore+       when (source /= target) $+         execSfxAtomic $ SfxMsgFid (bfid b1) SfxLevelNoMore+       -- We keep it useful even in shallow dungeons.+       recursiveCall $ IK.Teleport 30  -- powerful teleport+     | otherwise -> do+       (lid2, pos2) <- rndToAction $ oneOf destinations+       execSfx+       mbtime_bOld <-+         getsServer $ lookupActorTime (bfid b1) lid1 target . sactorTime+       mbtimeTraj_bOld <-+         getsServer $ lookupActorTime (bfid b1) lid1 target . strajTime+       pos3 <- findStairExit (bfid sb) up lid2 pos2+       let switch1 = void $ switchLevels1 (target, b1)+           switch2 = do+             -- Make the initiator of the stair move the leader,+             -- to let him clear the stairs for others to follow.+             let mlead = if bproj b1 then Nothing else Just target+             -- Move the actor to where the inhabitants were, if any.+             switchLevels2 lid2 pos3 (target, b1)+                           mbtime_bOld mbtimeTraj_bOld mlead+       -- The actor will be added to the new level,+       -- but there can be other actors at his new position.+       inhabitants <- getsState $ posToAidAssocs pos3 lid2+       case inhabitants of+         (_, b2) : _ | not $ bproj b1 -> do+           -- Alert about the switch.+           execSfxAtomic $ SfxMsgFid (bfid sb) SfxLevelPushed+           -- Only tell one pushed player, even if many actors, because then+           -- they are projectiles, so not too important.+           when (source /= target) $+             execSfxAtomic $ SfxMsgFid (bfid b2) SfxLevelPushed+           -- Move the actor out of the way.+           switch1+           -- Move the inhabitants out of the way and to where the actor was.+           let moveInh inh = do+                 -- Preserve the old leader, since the actor is pushed,+                 -- so possibly has nothing worhwhile to do on the new level+                 -- (and could try to switch back, if made a leader,+                 -- leading to a loop).+                 mbtime_inh <-+                   getsServer $ lookupActorTime (bfid (snd inh)) lid2 (fst inh)+                                . sactorTime+                 mbtimeTraj_inh <-+                   getsServer $ lookupActorTime (bfid (snd inh)) lid2 (fst inh)+                                . strajTime+                 inhMLead <- switchLevels1 inh+                 switchLevels2 lid1 (bpos b1) inh+                               mbtime_inh mbtimeTraj_inh inhMLead+           mapM_ moveInh inhabitants+           -- Move the actor to his destination.+           switch2+         _ -> do  -- no inhabitants or the stair-taker a projectile+           switch1+           switch2+       return UseUp++findStairExit :: MonadStateRead m+              => FactionId -> Bool -> LevelId -> Point -> m Point+findStairExit side moveUp lid pos = do+  COps{coTileSpeedup} <- getsState scops+  fact <- getsState $ (EM.! side) . sfactionD+  lvl <- getLevel lid+  let defLanding = uncurry Vector $ if moveUp then (1, 0) else (-1, 0)+      center = uncurry Vector $ if moveUp then (-1, 0) else (1, 0)+      (mvs2, mvs1) = break (== defLanding) moves+      mvs = center : filter (/= center) (mvs1 ++ mvs2)+      ps = filter (Tile.isWalkable coTileSpeedup . (lvl `at`))+           $ map (shift pos) mvs+      posOcc :: State -> Int -> Point -> Bool+      posOcc s k p = case posToAidAssocs p lid s of+        [] -> k == 0+        (_, b) : _ | bproj b -> k == 3+        (_, b) : _ | isFoe side fact (bfid b) -> k == 1  -- non-proj foe+        _ -> k == 2  -- moving a non-projectile friend+  unocc <- getsState posOcc+  case concatMap (\k -> filter (unocc k) ps) [0..3] of+    [] -> error $ "" `showFailure` ps+    posRes : _ -> return posRes++switchLevels1 :: MonadServerAtomic m => (ActorId, Actor) -> m (Maybe ActorId)+switchLevels1 (aid, bOld) = do+  let side = bfid bOld+  mleader <- getsState $ gleader . (EM.! side) . sfactionD+  -- Prevent leader pointing to a non-existing actor.+  mlead <-+    if not (bproj bOld) && isJust mleader then do+      execUpdAtomic $ UpdLeadFaction side mleader Nothing+      return mleader+        -- outside of a client we don't know the real tgt of aid, hence fst+    else return Nothing+  -- Remove the actor from the old level.+  -- Onlookers see somebody disappear suddenly.+  -- @UpdDestroyActor@ is too loud, so use @UpdLoseActor@ instead.+  execUpdAtomic $ UpdLoseActor aid bOld+  return mlead++switchLevels2 ::MonadServerAtomic m+              => LevelId -> Point -> (ActorId, Actor)+              -> Maybe Time -> Maybe Time -> Maybe ActorId+              -> m ()+switchLevels2 lidNew posNew (aid, bOld) mbtime_bOld mbtimeTraj_bOld mlead = do+  let lidOld = blid bOld+      side = bfid bOld+  let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `swith` lidNew) ()+  -- Sync actor's items' timeouts with the new local time of the level.+  -- We need to sync organs and equipment due to periodic activations,+  -- but also due to timeouts after use, e.g., for some weapons+  -- (they recharge also in the stash; however, this doesn't encourage+  -- micromanagement for periodic items, because the timeout is randomised+  -- upon move to equipment).+  --+  -- We don't rebase timeouts for items in stash, because they are+  -- used by many actors on levels with different local times,+  -- so there is no single rebase that would match all.+  -- This is not a big problem: after a single use by an actor the timeout is+  -- set to his current local time, so further uses by that actor have+  -- not anomalously short or long recharge times. If the recharge time+  -- is very long, the player has an option of moving the item away from stash+  -- and back, to reset the timeout. An abuse is possible when recently+  -- used item is put from equipment to stash and at once used on another level+  -- taking advantage of local time difference, but this only works once+  -- and using the item back again at the original level makes the recharge+  -- time longer, in turn.+  timeOld <- getsState $ getLocalTime lidOld+  timeLastActive <- getsState $ getLocalTime lidNew+  let delta = timeLastActive `timeDeltaToFrom` timeOld+      computeNewTimeout :: ItemQuant -> ItemQuant+      computeNewTimeout (k, it) = (k, map (shiftItemTimer delta) it)+      rebaseTimeout :: ItemBag -> ItemBag+      rebaseTimeout = EM.map computeNewTimeout+      bNew = bOld { blid = lidNew+                  , bpos = posNew+                  , boldpos = Just posNew  -- new level, new direction+                  , borgan = rebaseTimeout $ borgan bOld+                  , beqp = rebaseTimeout $ beqp bOld }+      shiftByDelta = (`timeShift` delta)+  -- Sync the actor time with the level time.+  -- This time shift may cause a double move of a foe of the same speed,+  -- but this is OK --- the foe didn't have a chance to move+  -- before, because the arena went inactive, so he moves now one more time.+  maybe (return ())+        (\btime_bOld ->+    modifyServer $ \ser ->+      ser {sactorTime = updateActorTime (bfid bNew) lidNew aid+                                        (shiftByDelta btime_bOld)+                        $ sactorTime ser})+        mbtime_bOld+  maybe (return ())+        (\btime_bOld ->+    modifyServer $ \ser ->+      ser {strajTime = updateActorTime (bfid bNew) lidNew aid+                                       (shiftByDelta btime_bOld)+                       $ strajTime ser})+        mbtimeTraj_bOld+  -- Materialize the actor at the new location.+  -- Onlookers see somebody appear suddenly. The actor himself+  -- sees new surroundings and has to reset his perception.+  execUpdAtomic $ UpdSpotActor aid bNew+  forM_ mlead $+    -- The leader is fresh in the sense that he's on a new level+    -- and so doesn't have up to date Perception.+    setFreshLeader side++-- ** Escape++-- | The faction leaves the dungeon.+effectEscape :: MonadServerAtomic m => m () -> ActorId -> ActorId -> m UseResult+effectEscape execSfx source target = do+  -- Obvious effect, nothing announced.+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  let fid = bfid tb+  fact <- getsState $ (EM.! fid) . sfactionD+  if | bproj tb ->+       return UseDud  -- basically a misfire+     | not (fcanEscape $ gkind fact) -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxEscapeImpossible+       when (source /= target) $+         execSfxAtomic $ SfxMsgFid (bfid tb) SfxEscapeImpossible+       return UseId+     | otherwise -> do+       execSfx+       deduceQuits (bfid tb) $ Status Escape (fromEnum $ blid tb) Nothing+       return UseUp++-- ** Paralyze++-- | Advance target actor time by this many time clips. Not by actor moves,+-- to hurt fast actors more.+effectParalyze :: MonadServerAtomic m+               => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult+effectParalyze execSfx nDm source target = do+  tb <- getsState $ getActorBody target+  if bproj tb then return UseDud  -- shortcut for speed+  else paralyze execSfx nDm source target++paralyze :: MonadServerAtomic m+         => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult+paralyze execSfx nDm source target = do+  tb <- getsState $ getActorBody target+  totalDepth <- getsState stotalDepth+  Level{ldepth} <- getLevel (blid tb)+  power0 <- rndToAction $ castDice ldepth totalDepth nDm+  let power = max power0 1  -- KISS, avoid special case+  actorStasis <- getsServer sactorStasis+  if ES.member target actorStasis then do+    sb <- getsState $ getActorBody source+    execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects+    when (source /= target) $+      execSfxAtomic $ SfxMsgFid (bfid tb) SfxStasisProtects+    return UseId+  else do+    execSfx+    let t = timeDeltaScale (Delta timeClip) power+    -- Only the normal time, not the trajectory time, is affected.+    modifyServer $ \ser ->+      ser { sactorTime = ageActor (bfid tb) (blid tb) target t+                         $ sactorTime ser+          , sactorStasis = ES.insert target (sactorStasis ser) }+              -- actor's time warped, so he is in stasis,+              -- immune to further warps+    return UseUp++-- ** ParalyzeInWater++-- | Advance target actor time by this many time clips. Not by actor moves,+-- to hurt fast actors more. Due to water, so resistable.+effectParalyzeInWater :: MonadServerAtomic m+                      => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult+effectParalyzeInWater execSfx nDm source target = do+  tb <- getsState $ getActorBody target+  if bproj tb then return UseDud else do  -- shortcut for speed+    actorMaxSk <- getsState $ getActorMaxSkills target+    let swimmingOrFlying = max (Ability.getSk Ability.SkSwimming actorMaxSk)+                               (Ability.getSk Ability.SkFlying actorMaxSk)+    if Dice.supDice nDm > swimmingOrFlying+    then paralyze execSfx nDm source target  -- no help at all+    else  -- fully resisted+      -- Don't spam:+      -- sb <- getsState $ getActorBody source+      -- execSfxAtomic $ SfxMsgFid (bfid sb) SfxWaterParalysisResisted+      return UseId++-- ** InsertMove++-- | Give target actor the given number of tenths of extra move. Don't give+-- an absolute amount of time units, to benefit slow actors more.+effectInsertMove :: MonadServerAtomic m+                 => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult+effectInsertMove execSfx nDm source target = do+  tb <- getsState $ getActorBody target+  actorMaxSk <- getsState $ getActorMaxSkills target+  totalDepth <- getsState stotalDepth+  Level{ldepth} <- getLevel (blid tb)+  actorStasis <- getsServer sactorStasis+  power0 <- rndToAction $ castDice ldepth totalDepth nDm+  let power = max power0 1  -- KISS, avoid special case+      actorTurn = ticksPerMeter $ gearSpeed actorMaxSk+      t = timeDeltaScale (timeDeltaPercent actorTurn 10) (-power)+  if | bproj tb -> return UseDud  -- shortcut for speed+     | ES.member target actorStasis -> do+       sb <- getsState $ getActorBody source+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects+       when (source /= target) $+         execSfxAtomic $ SfxMsgFid (bfid tb) SfxStasisProtects+       return UseId+     | otherwise -> do+       execSfx+       -- Only the normal time, not the trajectory time, is affected.+       modifyServer $ \ser ->+         ser { sactorTime = ageActor (bfid tb) (blid tb) target t+                            $ sactorTime ser+             , sactorStasis = ES.insert target (sactorStasis ser) }+                 -- actor's time warped, so he is in stasis,+                 -- immune to further warps+       return UseUp++-- ** Teleport++-- | Teleport the target actor.+-- Note that projectiles can be teleported, too, for extra fun.+effectTeleport :: MonadServerAtomic m+               => m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult+effectTeleport execSfx nDm source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  actorMaxSk <- getsState $ getActorMaxSkills target+  if | source /= target && Ability.getSk Ability.SkMove actorMaxSk <= 0 -> do+       execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible+       when (source /= target) $+         execSfxAtomic $ SfxMsgFid (bfid tb) SfxTransImpossible+       return UseId+     | source /= target && actorWaits tb -> do+         -- immune only against not own effects, to enable teleport+         -- as beneficial's necklace drawback; also consistent+         -- with sleep not protecting+       execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target+       when (source /= target) $+         execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxBracedImmune target+       return UseId+     | otherwise -> do+       COps{coTileSpeedup} <- getsState scops+       totalDepth <- getsState stotalDepth+       lvl@Level{ldepth} <- getLevel (blid tb)+       range <- rndToAction $ castDice ldepth totalDepth nDm+       let spos = bpos tb+           dMinMax !delta !pos =+             let d = chessDist spos pos+             in d >= range - delta && d <= range + delta+           dist !delta !pos _ = dMinMax delta pos+       mtpos <- rndToAction $ findPosTry 200 lvl+         (\p !t -> Tile.isWalkable coTileSpeedup t+                   && not (Tile.isNoActor coTileSpeedup t)+                   && not (occupiedBigLvl p lvl)+                   && not (occupiedProjLvl p lvl))+         [ dist 1+         , dist $ 1 + range `div` 9+         , dist $ 1 + range `div` 7+         , dist $ 1 + range `div` 5+         , dist 5+         , dist 7+         , dist 9+         ]+       case mtpos of+         Nothing -> do  -- really very rare, so debug+           debugPossiblyPrint+             "Server: effectTeleport: failed to find any free position"+           execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible+           when (source /= target) $+             execSfxAtomic $ SfxMsgFid (bfid tb) SfxTransImpossible+           return UseId+         Just tpos -> do+           execSfx+           execUpdAtomic $ UpdMoveActor target spos tpos+           return UseUp++-- ** CreateItem++effectCreateItem :: MonadServerAtomic m+                 => Maybe FactionId -> Maybe Int -> ActorId -> ActorId+                 -> Maybe ItemId -> CStore -> GroupName ItemKind -> IK.TimerDice+                 -> m UseResult+effectCreateItem jfidRaw mcount source target miidOriginal store grp tim = do+ tb <- getsState $ getActorBody target+ if bproj tb && store == COrgan  -- other stores OK not to lose possible loot+ then return UseDud  -- don't make a projectile hungry, etc.+ else do+  cops <- getsState scops+  sb <- getsState $ getActorBody source+  actorMaxSk <- getsState $ getActorMaxSkills target+  totalDepth <- getsState stotalDepth+  lvlTb <- getLevel (blid tb)+  let -- If the number of items independent of depth in @mcount@,+      -- make also the timer, the item kind choice and aspects+      -- independent of depth, via fixing the generation depth of the item+      -- to @totalDepth@. Prime example of provided @mcount@ is crafting.+      -- TODO: base this on a resource that can be consciously spent,+      -- not on a skill that grows over time or that only one actor+      -- maxes out and so needs to always be chosen for crafting.+      -- See https://www.reddit.com/r/roguelikedev/comments/phukcq/game_design_question_how_to_base_item_generation/+      depth = if isJust mcount then totalDepth else ldepth lvlTb+      fscale unit nDm = do+        k0 <- rndToAction $ castDice depth totalDepth nDm+        let k = max 1 k0  -- KISS, don't freak out if dice permit 0+        return $! timeDeltaScale unit k+      fgame = fscale (Delta timeTurn)+      factor nDm = do+        -- A bit added to make sure length 1 effect doesn't randomly+        -- end, or not, before the end of first turn, which would make,+        -- e.g., hasting, useless. This needs to be higher than 10%+        -- to compensate for overhead of animals, etc. (no leaders).+        let actorTurn =+              timeDeltaPercent (ticksPerMeter $ gearSpeed actorMaxSk) 111+        fscale actorTurn nDm+  delta <- IK.foldTimer (return $ Delta timeZero) fgame factor tim+  let c = CActor target store+  bagBefore <- getsState $ getBodyStoreBag tb store+  uniqueSet <- getsServer suniqueSet+  -- Power depth of new items unaffected by number of spawned actors, so 0.+  let freq = newItemKind cops uniqueSet [(grp, 1)] depth totalDepth 0+  m2 <- rollItemAspect freq depth+  case m2 of+    NoNewItem -> return UseDud  -- e.g., unique already generated+    NewItem _ itemKnownRaw itemFullRaw (kRaw, itRaw) -> do+      -- Avoid too many different item identifiers (one for each faction)+      -- for blasts or common item generating tiles. Conditions are+      -- allowed to be duplicated, because they provide really useful info+      -- (perpetrator). However, if timer is none, they are not duplicated+      -- to make sure that, e.g., poisons stack with each other regardless+      -- of perpetrator and we don't get "no longer poisoned" message+      -- while still poisoned due to another faction. With timed aspects,+      -- e.g., slowness, the message is less misleading, and it's interesting+      -- that I'm twice slower due to aspects from two factions and not+      -- as deadly as being poisoned at twice the rate from two factions.+      let jfid = if store == COrgan && not (IK.isTimerNone tim)+                    || grp == IK.S_IMPRESSED+                 then jfidRaw+                 else Nothing+          ItemKnown kindIx arItem _ = itemKnownRaw+          (itemKnown, itemFull) =+            ( ItemKnown kindIx arItem jfid+            , itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} )+      itemRev <- getsServer sitemRev+      let mquant = case HM.lookup itemKnown itemRev of+            Nothing -> Nothing+            Just iid -> (iid,) <$> iid `EM.lookup` bagBefore+      case mquant of+        Just (iid, (_, afterIt@(timer : rest))) | not $ IK.isTimerNone tim -> do+          -- Already has such items and timer change requested, so only increase+          -- the timer of the first item by the delta, but don't create items.+          let newIt = shiftItemTimer delta timer : rest+          if afterIt /= newIt then do+            execUpdAtomic $ UpdTimeItem iid c afterIt newIt+            -- It's hard for the client to tell this timer change from charge+            -- use, timer reset on pickup, etc., so we create the msg manually.+            -- Sending to both involved factions lets the player notice+            -- both the extensions he caused and suffered. Other faction causing+            -- that on themselves or on others won't be noticed. TMI.+            execSfxAtomic $ SfxMsgFid (bfid sb)+                          $ SfxTimerExtended target iid store delta+            when (bfid sb /= bfid tb) $+              execSfxAtomic $ SfxMsgFid (bfid tb)+                            $ SfxTimerExtended target iid store delta+            return UseUp+          else return UseDud  -- probably incorrect content, but let it be+        _ -> do+          localTime <- getsState $ getLocalTime (blid tb)+          let newTimer = createItemTimer localTime delta+              extraIt k = if IK.isTimerNone tim+                          then itRaw  -- don't break @applyPeriodicLevel@+                          else replicate k newTimer+                                 -- randomized and overwritten in @registerItem@+                                 -- if an organ or created in equipment+              kitNew = case mcount of+                Just itemK -> (itemK, extraIt itemK)+                Nothing -> (kRaw, extraIt kRaw)+          case miidOriginal of+            Just iidOriginal | store /= COrgan ->+              execSfxAtomic $ SfxMsgFid (bfid tb)+                            $ SfxItemYield iidOriginal (fst kitNew) (blid tb)+            _ -> return ()+          -- No such items or some items, but void delta, so create items.+          -- If it's, e.g., a periodic poison, the new items will stack with any+          -- already existing items.+          iid <- registerItem True (itemFull, kitNew) itemKnown c+          -- If created not on the ground, ID it, because it won't be on pickup.+          -- If ground and stash coincide, unindentified item enters stash,+          -- so will be identified when equipped, used or dropped+          -- and picked again.+          if isJust mcount  -- not a random effect, so probably crafting+             && not (IA.isHumanTrinket (itemKind itemFull))+          then execUpdAtomic $ UpdDiscover c iid (itemKindId itemFull) arItem+          else when (store /= CGround) $+            discoverIfMinorEffects c iid (itemKindId itemFull)+          return UseUp++-- ** DestroyItem++-- | Make the target actor destroy items in a store from the given group.+-- The item that caused the effect itself is *not* immune, because often+-- the item needs to destroy itself, e.g., to model wear and tear.+-- In such a case, the item may need to be identified, in a container,+-- when it no longer exists, at least in the container. This is OK.+-- Durable items are not immune, unlike the tools in @ConsumeItems@.+effectDestroyItem :: MonadServerAtomic m+                  => m () -> Int -> Int -> CStore -> ActorId+                  -> GroupName ItemKind+                  -> m UseResult+effectDestroyItem execSfx ngroup kcopy store target grp = do+  tb <- getsState $ getActorBody target+  is <- allGroupItems store grp target+  if null is then return UseDud+  else do+    execSfx+    urs <- mapM (uncurry (dropCStoreItem True True store target tb kcopy))+                (take ngroup is)+    return $! case urs of+      [] -> UseDud  -- there was no effects+      _ -> maximum urs++-- | Drop a single actor's item (though possibly multiple copies).+-- Note that if there are multiple copies, at most one explodes+-- to avoid excessive carnage and UI clutter (let's say,+-- the multiple explosions interfere with each other or perhaps+-- larger quantities of explosives tend to be packaged more safely).+-- Note also that @OnSmash@ effects are activated even if item discharged.+dropCStoreItem :: MonadServerAtomic m+               => Bool -> Bool -> CStore -> ActorId -> Actor -> Int+               -> ItemId -> ItemQuant+               -> m UseResult+dropCStoreItem verbose destroy store aid b kMax iid (k, _) = do+ let c = CActor aid store+ bag0 <- getsState $ getContainerBag c+  -- @OnSmash@ effects of previous items may remove next items, so better check.+ if iid `EM.notMember` bag0 then return UseDud else do+  itemFull <- getsState $ itemToFull iid+  let arItem = aspectRecordFull itemFull+      fragile = IA.checkFlag Ability.Fragile arItem+      durable = IA.checkFlag Ability.Durable arItem+      isDestroyed = destroy+                    || bproj b && (bhp b <= 0 && not durable || fragile)+                    || store == COrgan  -- just as organs are destroyed at death+                                        -- but also includes conditions+  if isDestroyed then do+    let effApplyFlags = EffApplyFlags+          { effToUse            = EffBare+              -- the embed could be combined at this point but @iid@ cannot+          , effVoluntary        = True+              -- we don't know if it's effVoluntary, so we conservatively assume+              -- it is and we blame @aid@+          , effUseAllCopies     = kMax >= k+          , effKineticPerformed = False+          , effActivation       = ActivationOnSmash+          , effMayDestroy       = True+          }+    void $ effectAndDestroyAndAddKill effApplyFlags aid aid aid iid c itemFull+    -- One copy was destroyed (or none if the item was discharged),+    -- so let's mop up.+    bag <- getsState $ getContainerBag c+    maybe (return ())+          (\(k1, it) -> do+             let destroyedSoFar = k - k1+                 k2 = min (kMax - destroyedSoFar) k1+                 kit2 = (k2, take k2 it)+                 -- Don't spam if the effect already probably made noise+                 -- and also the number could be surprising to the player.+                 verbose2 = verbose && k1 == k+             when (k2 > 0) $+               execUpdAtomic $ UpdDestroyItem verbose2 iid (itemBase itemFull)+                                              kit2 c)+          (EM.lookup iid bag)+    return UseUp+  else do+    cDrop <- pickDroppable False aid b  -- drop over fog, etc.+    mvCmd <- generalMoveItem verbose iid (min kMax k) (CActor aid store) cDrop+    mapM_ execUpdAtomic mvCmd+    return UseUp++pickDroppable :: MonadStateRead m => Bool -> ActorId -> Actor -> m Container+pickDroppable respectNoItem aid b = do+  cops@COps{coTileSpeedup} <- getsState scops+  lvl <- getLevel (blid b)+  let validTile t = not (respectNoItem && Tile.isNoItem coTileSpeedup t)+  if validTile $ lvl `at` bpos b+  then return $! CActor aid CGround+  else do+    let ps = nearbyFreePoints cops lvl validTile (bpos b)+    return $! case filter (adjacent $ bpos b) $ take 8 ps of+      [] -> CActor aid CGround  -- fallback; still correct, though not ideal+      pos : _ -> CFloor (blid b) pos++-- ** ConsumeItems++-- | Make the target actor destroy the given items, if all present,+-- or none at all, if any is missing. To be used in crafting.+-- The item that caused the effect itself is not considered (any copies).+effectConsumeItems :: MonadServerAtomic m+                   => m () -> ItemId -> ActorId+                   -> [(Int, GroupName ItemKind)]+                   -> [(Int, GroupName ItemKind)]+                   -> m UseResult+effectConsumeItems execSfx iidOriginal target tools0 raw0 = do+  kitAssG <- getsState $ kitAssocs target [CGround]+  let kitAss = listToolsToConsume kitAssG []  -- equipment too dangerous to use+      is = filter ((/= iidOriginal) . fst . snd) kitAss+      grps0 = map (\(x, y) -> (False, x, y)) tools0  -- apply if durable+              ++ map (\(x, y) -> (True, x, y)) raw0  -- destroy always+      (bagsToLose3, iidsToApply3, grps3) =+        foldl' subtractIidfromGrps (EM.empty, [], grps0) is+  if null grps3 then do+    execSfx+    consumeItems target bagsToLose3 iidsToApply3+    return UseUp+  else return UseDud++consumeItems :: MonadServerAtomic m+             => ActorId -> EM.EnumMap CStore ItemBag+             -> [(CStore, (ItemId, ItemFull))]+             -> m ()+consumeItems target bagsToLose iidsToApply = do+  COps{coitem} <- getsState scops+  tb <- getsState $ getActorBody target+  arTrunk <- getsState $ (EM.! btrunk tb) . sdiscoAspect+  let isBlast = IA.checkFlag Ability.Blast arTrunk+      identifyStoreBag store bag =+        mapM_ (identifyStoreIid store) $ EM.keys bag+      identifyStoreIid store iid = do+        discoAspect2 <- getsState sdiscoAspect+          -- might have changed due to embedded items invocations+        itemKindId <- getsState $ getIidKindIdServer iid+        let arItem = discoAspect2 EM.! iid+            c = CActor target store+            itemKind = okind coitem itemKindId+        unless (IA.isHumanTrinket itemKind) $  -- a hack+          execUpdAtomic $ UpdDiscover c iid itemKindId arItem+  -- We don't invoke @OnSmash@ effects, so we avoid the risk+  -- of the first removed item displacing the actor, destroying+  -- or scattering some pending items ahead of time, etc.+  -- The embed should provide any requisite fireworks instead.+  forM_ (EM.assocs bagsToLose) $ \(store, bagToLose) ->+    unless (EM.null bagToLose) $ do+      identifyStoreBag store bagToLose+      -- Not @UpdLoseItemBag@, to be verbose.+      -- The bag is small, anyway.+      let c = CActor target store+      itemD <- getsState sitemD+      mapWithKeyM_ (\iid kit -> do+                      let verbose = not isBlast  -- no spam+                          item = itemD EM.! iid+                      execUpdAtomic $ UpdDestroyItem verbose iid item kit c)+                   bagToLose+  -- But afterwards we do apply normal effects of durable items,+  -- even if the actor or other items displaced in the process,+  -- as long as a number of the items is still there.+  -- So if a harmful double-purpose tool-component is both to be used+  -- and destroyed, it will be lost, but at least it won't harm anybody.+  let applyItemIfPresent (store, (iid, itemFull)) = do+        let c = CActor target store+        bag <- getsState $ getContainerBag c+        when (iid `EM.member` bag) $ do+          execSfxAtomic $ SfxApply target iid+          -- Treated as if the actor only activated the item on himself,+          -- without kinetic damage, to avoid the exploit of wearing armor+          -- when using tools or transforming terrain.+          -- Also, timeouts of the item ignored to prevent exploit+          -- by discharging the item before using it.+          let effApplyFlags = EffApplyFlags+                { effToUse            = EffBare  -- crafting not intended+                , effVoluntary        = True+                , effUseAllCopies     = False+                , effKineticPerformed = False+                , effActivation       = ActivationConsume+                , effMayDestroy       = False+                }+          void $ effectAndDestroyAndAddKill effApplyFlags+                                            target target target iid c itemFull+  mapM_ applyItemIfPresent iidsToApply++-- ** DropItem++-- | Make the target actor drop items in a store from the given group.+-- The item that caused the effect itself is immune (any copies).+effectDropItem :: MonadServerAtomic m+               => m () -> ItemId -> Int -> Int -> CStore+               -> GroupName ItemKind -> ActorId+               -> m UseResult+effectDropItem execSfx iidOriginal ngroup kcopy store grp target = do+  tb <- getsState $ getActorBody target+  fact <- getsState $ (EM.! bfid tb) . sfactionD+  isRaw <- allGroupItems store grp target+  curChalSer <- getsServer $ scurChalSer . soptions+  factionD <- getsState sfactionD+  let is = filter ((/= iidOriginal) . fst) isRaw+  if | bproj tb || null is -> return UseDud+     | ngroup == maxBound && kcopy == maxBound+       && store `elem` [CStash, CEqp]+       && fhasGender (gkind fact)  -- hero in Allure's decontamination chamber+       && (cdiff curChalSer == 1   -- at lowest difficulty for its faction+           && any (fhasUI . gkind . snd)+                  (filter (\(fi, fa) -> isFriend fi fa (bfid tb))+                          (EM.assocs factionD))+           || cdiff curChalSer == difficultyBound+              && any (fhasUI . gkind  . snd)+                     (filter (\(fi, fa) -> isFoe fi fa (bfid tb))+                             (EM.assocs factionD))) ->+{-+A hardwired hack, because AI heroes don't cope with Allure's decontamination+chamber; beginners may struggle too, so this is trigered by difficulty.+- AI heroes don't switch leader to the hero past laboratory to equip+weapons from stash between the in-lab hero picks up the loot pile+and himself enters the decontamination chamber+- the items of the last actor would be lost anyway, unless AI+is taught the foolproof solution of this puzzle, which is yet a bit more+specific than the two abilities above+-}+       return UseUp+     | otherwise -> do+       unless (store == COrgan) execSfx+       urs <- mapM (uncurry (dropCStoreItem True False store target tb kcopy))+                   (take ngroup is)+       return $! case urs of+         [] -> UseDud  -- there was no effects+         _ -> maximum urs++-- ** Recharge and Discharge++effectRecharge :: forall m. MonadServerAtomic m+               => Bool -> m () -> ItemId -> Int -> Dice.Dice -> ActorId+               -> m UseResult+effectRecharge reducingCooldown execSfx iidOriginal n0 dice target = do+ tb <- getsState $ getActorBody target+ if bproj tb then return UseDud else do  -- slows down, but rarely any effect+  localTime <- getsState $ getLocalTime (blid tb)+  totalDepth <- getsState stotalDepth+  Level{ldepth} <- getLevel $ blid tb+  power <- rndToAction $ castDice ldepth totalDepth dice+  let timeUnit = if reducingCooldown+                 then absoluteTimeNegate timeClip+                 else timeClip+      delta = timeDeltaScale (Delta timeUnit) power+      localTimer = createItemTimer localTime (Delta timeZero)+      addToCooldown :: CStore -> (Int, UseResult) -> (ItemId, ItemFullKit)+                    -> m (Int, UseResult)+      addToCooldown _ (0, ur) _ = return (0, ur)+      addToCooldown store (n, ur) (iid, (_, (k0, itemTimers0))) = do+        let itemTimers = filter (charging localTime) itemTimers0+            kt = length itemTimers+            lenToShift = min n $ if reducingCooldown then kt else k0 - kt+            (itToShift, itToKeep) =+              if reducingCooldown+              then splitAt lenToShift itemTimers+              else (replicate lenToShift localTimer, itemTimers)+            -- No problem if this overcharges; equivalent to pruned timer.+            it2 = map (shiftItemTimer delta) itToShift ++ itToKeep+        if itemTimers0 == it2+        then return (n, ur)+        else do+          let c = CActor target store+          execUpdAtomic $ UpdTimeItem iid c itemTimers0 it2+          return (n - lenToShift, UseUp)+      selectWeapon i@(iid, (itemFull, _)) (weapons, others) =+        let arItem = aspectRecordFull itemFull+        in if | IA.aTimeout arItem == 0+                || iid == iidOriginal -> (weapons, others)+              | IA.checkFlag Ability.Meleeable arItem -> (i : weapons, others)+              | otherwise -> (weapons, i : others)+      partitionWeapon = foldr selectWeapon ([],[])+      ignoreCharges = True  -- handled above depending on @reducingCooldown@+      benefits = Nothing  -- only raw damage counts (client knows benefits)+      sortWeapons ass =+        map (\(_, _, _, _, iid, itemFullKit) -> (iid, itemFullKit))+        $ strongestMelee ignoreCharges benefits localTime ass+  eqpAss <- getsState $ kitAssocs target [CEqp]+  let (eqpAssWeapons, eqpAssOthers) = partitionWeapon eqpAss+  organAss <- getsState $ kitAssocs target [COrgan]+  let (organAssWeapons, organAssOthers) = partitionWeapon organAss+  (nEqpWeapons, urEqpWeapons) <-+    foldM (addToCooldown CEqp) (n0, UseDud)+    $ sortWeapons eqpAssWeapons+  (nOrganWeapons, urOrganWeapons) <-+    foldM (addToCooldown COrgan) (nEqpWeapons, urEqpWeapons)+    $ sortWeapons organAssWeapons+  (nEqpOthers, urEqpOthers) <-+    foldM (addToCooldown CEqp) (nOrganWeapons, urOrganWeapons) eqpAssOthers+  (_nOrganOthers, urOrganOthers) <-+    foldM (addToCooldown COrgan) (nEqpOthers, urEqpOthers) organAssOthers+  if urOrganOthers == UseDud then return UseDud+  else do+    execSfx+    return UseUp++-- ** PolyItem++-- Can't apply to the item itself (any copies).+effectPolyItem :: MonadServerAtomic m+               => m () -> ItemId -> ActorId -> m UseResult+effectPolyItem execSfx iidOriginal target = do+  tb <- getsState $ getActorBody target+  let cstore = CGround+  kitAss <- getsState $ kitAssocs target [cstore]+  case filter ((/= iidOriginal) . fst) kitAss of+    [] -> do+      execSfxAtomic $ SfxMsgFid (bfid tb) SfxPurposeNothing+      -- Do not spam the source actor player about the failures.+      return UseId+    (iid, ( itemFull@ItemFull{itemBase, itemKindId, itemKind}+          , (itemK, itemTimer) )) : _ -> do+      let arItem = aspectRecordFull itemFull+          maxCount = Dice.supDice $ IK.icount itemKind+      if | IA.checkFlag Ability.Unique arItem -> do+           execSfxAtomic $ SfxMsgFid (bfid tb) SfxPurposeUnique+           return UseId+         | maybe True (<= 0) $ lookup IK.COMMON_ITEM $ IK.ifreq itemKind -> do+           execSfxAtomic $ SfxMsgFid (bfid tb) SfxPurposeNotCommon+           return UseId+         | itemK < maxCount -> do+           execSfxAtomic $ SfxMsgFid (bfid tb)+                         $ SfxPurposeTooFew maxCount itemK+           return UseId+         | otherwise -> do+           -- Only the required number of items is used up, not all of them.+           let c = CActor target cstore+               kit = (maxCount, take maxCount itemTimer)+           execSfx+           identifyIid iid c itemKindId itemKind+           execUpdAtomic $ UpdDestroyItem True iid itemBase kit c+           effectCreateItem (Just $ bfid tb) Nothing+                            target target Nothing cstore+                            IK.COMMON_ITEM IK.timerNone++-- ** RerollItem++-- Can't apply to the item itself (any copies).+effectRerollItem :: forall m . MonadServerAtomic m+                 => m () -> ItemId -> ActorId -> m UseResult+effectRerollItem execSfx iidOriginal target = do+  COps{coItemSpeedup} <- getsState scops+  tb <- getsState $ getActorBody target+  let cstore = CGround  -- if ever changed, call @discoverIfMinorEffects@+  kitAss <- getsState $ kitAssocs target [cstore]+  case filter ((/= iidOriginal) . fst) kitAss of+    [] -> do+      execSfxAtomic $ SfxMsgFid (bfid tb) SfxRerollNothing+      -- Do not spam the source actor player about the failures.+      return UseId+    (iid, ( ItemFull{ itemBase, itemKindId, itemKind+                    , itemDisco=ItemDiscoFull itemAspect }+          , (_, itemTimer) )) : _ ->+      if IA.kmConst $ getKindMean itemKindId coItemSpeedup then do+        execSfxAtomic $ SfxMsgFid (bfid tb) SfxRerollNotRandom+        return UseId+      else do+        let c = CActor target cstore+            kit = (1, take 1 itemTimer)  -- prevent micromanagement+            freq = pure (IK.HORROR, itemKindId, itemKind)+        execSfx+        identifyIid iid c itemKindId itemKind+        execUpdAtomic $ UpdDestroyItem False iid itemBase kit c+        totalDepth <- getsState stotalDepth+        let roll100 :: Int -> m (ItemKnown, ItemFull)+            roll100 n = do+              -- Not only rerolled, but at highest depth possible,+              -- resulting in highest potential for bonuses.+              m2 <- rollItemAspect freq totalDepth+              case m2 of+                NoNewItem ->+                  error "effectRerollItem: can't create rerolled item"+                NewItem _ itemKnown@(ItemKnown _ ar2 _) itemFull _ ->+                  if ar2 == itemAspect && n > 0+                  then roll100 (n - 1)+                  else return (itemKnown, itemFull)+        (itemKnown, itemFull) <- roll100 100+        void $ registerItem True (itemFull, kit) itemKnown c+        return UseUp+    _ -> error "effectRerollItem: server ignorant about an item"++-- ** DupItem++-- Can't apply to the item itself (any copies).+effectDupItem :: MonadServerAtomic m => m () -> ItemId -> ActorId -> m UseResult+effectDupItem execSfx iidOriginal target = do+  tb <- getsState $ getActorBody target+  let cstore = CGround  -- beware of other options, e.g., creating in eqp+                        -- and not setting timeout to a random value+  kitAss <- getsState $ kitAssocs target [cstore]+  case filter ((/= iidOriginal) . fst) kitAss of+    [] -> do+      execSfxAtomic $ SfxMsgFid (bfid tb) SfxDupNothing+      -- Do not spam the source actor player about the failures.+      return UseId+    (iid, ( itemFull@ItemFull{itemKindId, itemKind}+          , _ )) : _ -> do+      let arItem = aspectRecordFull itemFull+      if | IA.checkFlag Ability.Unique arItem -> do+           execSfxAtomic $ SfxMsgFid (bfid tb) SfxDupUnique+           return UseId+         | maybe False (> 0) $ lookup IK.VALUABLE $ IK.ifreq itemKind -> do+           execSfxAtomic $ SfxMsgFid (bfid tb) SfxDupValuable+           return UseId+         | otherwise -> do+           let c = CActor target cstore+           execSfx+           identifyIid iid c itemKindId itemKind+           let slore = IA.loreFromContainer arItem c+           modifyServer $ \ser ->+             ser {sgenerationAn = EM.adjust (EM.insertWith (+) iid 1) slore+                                            (sgenerationAn ser)}+           execUpdAtomic $ UpdCreateItem True iid (itemBase itemFull)+                                         quantSingle c+           return UseUp++-- ** Identify++effectIdentify :: MonadServerAtomic m+               => m () -> ItemId -> ActorId -> m UseResult+effectIdentify execSfx iidOriginal target = do+  COps{coItemSpeedup} <- getsState scops+  discoAspect <- getsState sdiscoAspect+  -- The actor that causes the application does not determine what item+  -- is identifiable, becuase it's the target actor that identifies+  -- his possesions.+  tb <- getsState $ getActorBody target+  sClient <- getsServer $ (EM.! bfid tb) . sclientStates+  let tryFull store as = case as of+        [] -> return False+        (iid, _) : rest | iid == iidOriginal -> tryFull store rest  -- don't id itself+        (iid, ItemFull{itemBase, itemKindId, itemKind}) : rest -> do+          let arItem = discoAspect EM.! iid+              kindIsKnown = case jkind itemBase of+                IdentityObvious _ -> True+                IdentityCovered ix _ -> ix `EM.member` sdiscoKind sClient+          if iid `EM.member` sdiscoAspect sClient  -- already fully identified+             || IA.isHumanTrinket itemKind  -- hack; keep them non-identified+             || store == CGround && IA.onlyMinorEffects arItem itemKind+               -- will be identified when picked up, so don't bother+             || IA.kmConst (getKindMean itemKindId coItemSpeedup)+                && kindIsKnown+               -- constant aspects and known kind; no need to identify further;+               -- this should normally not be needed, since clients should+               -- identify such items for free+          then tryFull store rest+          else do+            let c = CActor target store+            execSfx+            identifyIid iid c itemKindId itemKind+            return True+      tryStore stores = case stores of+        [] -> do+          execSfxAtomic $ SfxMsgFid (bfid tb) SfxIdentifyNothing+          return UseId  -- the message tells it's ID effect+        store : rest -> do+          allAssocs <- getsState $ fullAssocs target [store]+          go <- tryFull store allAssocs+          if go then return UseUp else tryStore rest+  tryStore [CGround, CStash, CEqp]++-- The item need not be in the container. It's used for a message only.+identifyIid :: MonadServerAtomic m+            => ItemId -> Container -> ContentId ItemKind -> ItemKind -> m ()+identifyIid iid c itemKindId itemKind =+  unless (IA.isHumanTrinket itemKind) $ do+    discoAspect <- getsState sdiscoAspect+    execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid++-- ** Detect++effectDetect :: MonadServerAtomic m+             => m () -> IK.DetectKind -> Int -> ActorId -> Container+             -> m UseResult+effectDetect execSfx d radius target container = do+  COps{coitem, coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody target+  lvl <- getLevel $ blid b+  sClient <- getsServer $ (EM.! bfid b) . sclientStates+  let lvlClient = (EM.! blid b) . sdungeon $ sClient+  s <- getState+  getKind <- getsState $ flip getIidKindServer+  factionD <- getsState sfactionD+  let lootPredicate p =+        p `EM.member` lfloor lvl+        || (case posToBigAssoc p (blid b) s of+              Nothing -> False+              Just (_, body) ->+                let belongings = EM.keys (beqp body)  -- shared stash ignored+                in any belongingIsLoot belongings)+        || any embedHasLoot (EM.keys $ getEmbedBag (blid b) p s)+      itemKindIsLoot = isNothing . lookup IK.UNREPORTED_INVENTORY . IK.ifreq+      belongingIsLoot iid = itemKindIsLoot $ getKind iid+      embedHasLoot iid = any effectHasLoot $ IK.ieffects $ getKind iid+      reported acc _ _ itemKind = acc && itemKindIsLoot itemKind+      effectHasLoot (IK.CreateItem _ cstore grp _) =+        cstore `elem` [CGround, CStash, CEqp]+        && ofoldlGroup' coitem grp reported True+      effectHasLoot IK.PolyItem = True+      effectHasLoot IK.RerollItem = True+      effectHasLoot IK.DupItem = True+      effectHasLoot (IK.AtMostOneOf l) = any effectHasLoot l+      effectHasLoot (IK.OneOf l) = any effectHasLoot l+      effectHasLoot (IK.OnSmash eff) = effectHasLoot eff+      effectHasLoot (IK.OnUser eff) = effectHasLoot eff+      effectHasLoot (IK.AndEffect eff1 eff2) =+        effectHasLoot eff1 || effectHasLoot eff2+      effectHasLoot (IK.OrEffect eff1 eff2) =+        effectHasLoot eff1 || effectHasLoot eff2+      effectHasLoot (IK.SeqEffect effs) =+        any effectHasLoot effs+      effectHasLoot (IK.When _ eff) = effectHasLoot eff+      effectHasLoot (IK.Unless _ eff) = effectHasLoot eff+      effectHasLoot (IK.IfThenElse _ eff1 eff2) =+        effectHasLoot eff1 || effectHasLoot eff2+      effectHasLoot _ = False+      stashPredicate p = any (onStash p) $ EM.assocs factionD+      onStash p (fid, fact) = case gstash fact of+        Just (lid, pos) -> pos == p && lid == blid b && fid /= bfid b+        Nothing -> False+      (predicate, action) = case d of+        IK.DetectAll -> (const True, const $ return False)+        IK.DetectActor -> ((`EM.member` lbig lvl), const $ return False)+        IK.DetectLoot -> (lootPredicate, const $ return False)+        IK.DetectExit ->+          let (ls1, ls2) = lstair lvl+          in ((`elem` ls1 ++ ls2 ++ lescape lvl), const $ return False)+        IK.DetectHidden ->+          let predicateH p = let tClient = lvlClient `at` p+                                 tServer = lvl `at` p+                             in Tile.isHideAs coTileSpeedup tServer+                                && tClient /= tServer+                -- the actor searches only tiles he doesn't know already,+                -- preventing misleading messages (and giving less information+                -- to eavesdropping parties)+              revealEmbed p = do+                embeds <- getsState $ getEmbedBag (blid b) p+                unless (EM.null embeds) $+                  execUpdAtomic $ UpdSpotItemBag True (CEmbed (blid b) p) embeds+              actionH l = do+                pos <- getsState $ posFromC container+                let f p = when (p /= pos) $ do+                      let t = lvl `at` p+                      execUpdAtomic $ UpdSearchTile target p t+                      -- This is safe searching; embedded items+                      -- are not triggered, but they are revealed.+                      revealEmbed p+                      case EM.lookup p $ lentry lvl of+                        Nothing -> return ()+                        Just entry ->+                          execUpdAtomic $ UpdSpotEntry (blid b) [(p, entry)]+                mapM_ f l+                return $! not $ null l+          in (predicateH, actionH)+        IK.DetectEmbed -> ((`EM.member` lembed lvl), const $ return False)+        IK.DetectStash -> (stashPredicate, const $ return False)+  effectDetectX d predicate action execSfx radius target++-- This is not efficient at all, so optimize iff detection is added+-- to periodic organs or common periodic items or often activated embeds.+effectDetectX :: MonadServerAtomic m+              => IK.DetectKind -> (Point -> Bool) -> ([Point] -> m Bool)+              -> m () -> Int -> ActorId -> m UseResult+effectDetectX d predicate action execSfx radius target = do+  COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops+  b <- getsState $ getActorBody target+  sperFidOld <- getsServer sperFid+  let perOld = sperFidOld EM.! bfid b EM.! blid b+      Point x0 y0 = bpos b+      perList = filter predicate+        [ Point x y+        | y <- [max 0 (y0 - radius) .. min (rHeightMax - 1) (y0 + radius)]+        , x <- [max 0 (x0 - radius) .. min (rWidthMax - 1) (x0 + radius)]+        ]+      extraPer = emptyPer {psight = PerVisible $ ES.fromDistinctAscList perList}+      inPer = diffPer extraPer perOld+  unless (nullPer inPer) $ do+    -- Perception is modified on the server and sent to the client+    -- together with all the revealed info.+    let perNew = addPer inPer perOld+        fper = EM.adjust (EM.insert (blid b) perNew) (bfid b)+    modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}+    execSendPer (bfid b) (blid b) emptyPer inPer perNew+  pointsModified <- action perList+  if not (nullPer inPer) || pointsModified then do+    execSfx+    -- Perception is reverted. This is necessary to ensure save and restore+    -- doesn't change game state.+    unless (nullPer inPer) $ do+      modifyServer $ \ser -> ser {sperFid = sperFidOld}+      execSendPer (bfid b) (blid b) inPer emptyPer perOld+  else+    execSfxAtomic $ SfxMsgFid (bfid b) $ SfxVoidDetection d+  return UseUp  -- even if nothing spotted, in itself it's still useful data++-- ** SendFlying++-- | Send the target actor flying like a projectile. If the actors are adjacent,+-- the vector is directed outwards, if no, inwards, if it's the same actor,+-- boldpos is used, if it can't, a random outward vector of length 10+-- is picked.+effectSendFlying :: MonadServerAtomic m+                 => m () -> IK.ThrowMod -> ActorId -> ActorId -> Container+                 -> Maybe Bool+                 -> m UseResult+effectSendFlying execSfx IK.ThrowMod{..} source target container modePush = do+  v <- sendFlyingVector source target container modePush+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  let eps = 0+      fpos = bpos tb `shift` v+      isEmbed = case container of+        CEmbed{} -> True+        _ -> False+  if bhp tb <= 0  -- avoid dragging around corpses+     || bproj tb && isEmbed then  -- flying projectiles can't slip on the floor+    return UseDud  -- the impact never manifested+  else if actorWaits tb+          && source /= target+          && isNothing (btrajectory tb) then do+    execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target+    when (source /= target) $+      execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxBracedImmune target+    return UseUp  -- waste it to prevent repeated throwing at immobile actors+  else do+   case bresenhamsLineAlgorithm eps (bpos tb) fpos of+    Nothing -> error $ "" `showFailure` (fpos, tb)+    Just [] -> error $ "projecting from the edge of level"+                       `showFailure` (fpos, tb)+    Just (pos : rest) -> do+      weightAssocs <- getsState $ fullAssocs target [CEqp, COrgan]+      let weight = sum $ map (IK.iweight . itemKind . snd) weightAssocs+          path = bpos tb : pos : rest+          (trajectory, (speed, _)) =+            -- Note that the @ThrowMod@ aspect of the actor's trunk is ignored.+            computeTrajectory weight throwVelocity throwLinger path+          ts = Just (trajectory, speed)+      -- Old and new trajectories are not added; the old one is replaced.+      if btrajectory tb == ts+      then return UseId  -- e.g., actor is too heavy; but a jerk is noticeable+      else do+        execSfx+        execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts+        -- If propeller is a projectile, it pushes involuntarily,+        -- so its originator is to blame.+        -- However, we can't easily see whether a pushed non-projectile actor+        -- pushed another due to colliding or voluntarily, so we assign+        -- blame to him.+        originator <- if bproj sb+                      then getsServer $ EM.findWithDefault source source+                                        . strajPushedBy+                      else return source+        modifyServer $ \ser ->+          ser {strajPushedBy = EM.insert target originator $ strajPushedBy ser}+        -- In case of pre-existing pushing, don't touch the time+        -- so that the pending @advanceTimeTraj@ can do its job+        -- (it will, because non-empty trajectory is here set, unless, e.g.,+        -- subsequent effects from the same item change the trajectory).+        when (isNothing $ btrajectory tb) $ do+          -- Set flying time to almost now, so that the push happens ASAP,+          -- because it's the first one, so almost no delay is needed.+          localTime <- getsState $ getLocalTime (blid tb)+          -- But add a slight overhead to avoid displace-slide loops+          -- of 3 actors in a line. However, add even more overhead+          -- to normal actor move, so that it doesn't manage to land+          -- a hit before it flies away safely.+          let overheadTime = timeShift localTime (Delta timeClip)+              doubleClip = timeDeltaScale (Delta timeClip) 2+          modifyServer $ \ser ->+            ser { strajTime =+                    updateActorTime (bfid tb) (blid tb) target overheadTime+                    $ strajTime ser+                , sactorTime =+                    ageActor (bfid tb) (blid tb) target doubleClip+                    $ sactorTime ser }+        return UseUp++sendFlyingVector :: MonadServerAtomic m+                 => ActorId -> ActorId -> Container -> Maybe Bool -> m Vector+sendFlyingVector source target container modePush = do+  sb <- getsState $ getActorBody source+  if source == target then do+    pos <- getsState $ posFromC container+    lid <- getsState $ lidFromC container+    let (start, end) =+          -- Without the level the pushing stair trap moved actor back upstairs.+          if bpos sb /= pos && blid sb == lid+          then (bpos sb, pos)+          else (fromMaybe (bpos sb) (boldpos sb), bpos sb)+    if start == end then rndToAction $ do+      z <- randomR (-10, 10)+      oneOf [Vector 10 z, Vector (-10) z, Vector z 10, Vector z (-10)]+    else do+      let pushV = vectorToFrom end start+          pullV = vectorToFrom start end+      return $! case modePush of+                  Just True -> pushV+                  Just False -> pullV+                  Nothing -> pushV+  else do+    tb <- getsState $ getActorBody target+    let pushV = vectorToFrom (bpos tb) (bpos sb)+        pullV = vectorToFrom (bpos sb) (bpos tb)+    return $! case modePush of+                Just True -> pushV+                Just False -> pullV+                Nothing | adjacent (bpos sb) (bpos tb) -> pushV+                Nothing -> pullV++-- ** ApplyPerfume++effectApplyPerfume :: MonadServerAtomic m => m () -> ActorId -> m UseResult+effectApplyPerfume execSfx target = do+  tb <- getsState $ getActorBody target+  Level{lsmell} <- getLevel $ blid tb+  unless (EM.null lsmell) $ do+    execSfx+    let f p fromSm = execUpdAtomic $ UpdAlterSmell (blid tb) p fromSm timeZero+    mapWithKeyM_ f lsmell+  return UseUp  -- even if no smell before, the perfume is noticeable++-- ** AtMostOneOf++effectAtMostOneOf :: MonadServerAtomic m+                  => (IK.Effect -> m UseResult) -> [IK.Effect] -> m UseResult+effectAtMostOneOf recursiveCall l = do+  chosen <- rndToAction $ oneOf l+  recursiveCall chosen+  -- no @execSfx@, because the individual effect sents it++-- ** OneOf++effectOneOf :: MonadServerAtomic m+            => (IK.Effect -> m UseResult) -> [IK.Effect] -> m UseResult+effectOneOf recursiveCall l = do+  shuffled <- rndToAction $ shuffle l+  let f eff result = do+        ur <- recursiveCall eff+        -- We stop at @UseId@ activation and in this ways avoid potentially+        -- many calls to fizzling effects that only spam a failure message+        -- and ID the item.+        if ur == UseDud then result else return ur+  foldr f (return UseDud) shuffled+  -- no @execSfx@, because the individual effect sents it++-- ** AndEffect++effectAndEffect :: forall m. MonadServerAtomic m+                => (IK.Effect -> m UseResult) -> ActorId+                -> IK.Effect -> IK.Effect+                -> m UseResult+effectAndEffect recursiveCall source eff1@IK.ConsumeItems{} eff2 = do+  -- So far, this is the only idiom used for crafting. If others appear,+  -- either formalize it by a specialized crafting effect constructor+  -- or add here and to effect printing code.+  sb <- getsState $ getActorBody source+  curChalSer <- getsServer $ scurChalSer . soptions+  fact <- getsState $ (EM.! bfid sb) . sfactionD+  if cgoods curChalSer && fhasUI (gkind fact) then do+    execSfxAtomic $ SfxMsgFid (bfid sb) SfxReadyGoods+    return UseId+  else effectAndEffectSem recursiveCall eff1 eff2++effectAndEffect recursiveCall _ eff1 eff2 =+  effectAndEffectSem recursiveCall eff1 eff2++effectAndEffectSem :: forall m. MonadServerAtomic m+                   => (IK.Effect -> m UseResult) -> IK.Effect -> IK.Effect+                   -> m UseResult+effectAndEffectSem recursiveCall eff1 eff2 = do+  ur1 <- recursiveCall eff1+  if ur1 == UseUp+  then recursiveCall eff2+  else return ur1+  -- No @execSfx@, because individual effects sent them.++-- ** OrEffect++effectOrEffect :: forall m. MonadServerAtomic m+               => (IK.Effect -> m UseResult)+               -> FactionId -> IK.Effect -> IK.Effect+               -> m UseResult+effectOrEffect recursiveCall fid eff1 eff2 = do+  curChalSer <- getsServer $ scurChalSer . soptions+  fact <- getsState $ (EM.! fid) . sfactionD+  case eff1 of+    IK.AndEffect IK.ConsumeItems{} _ | cgoods curChalSer+                                       && fhasUI (gkind fact) -> do+      -- Stop forbidden crafting ASAP to avoid spam.+      execSfxAtomic $ SfxMsgFid fid SfxReadyGoods+      return UseId+    _ -> do+      ur1 <- recursiveCall eff1+      if ur1 == UseUp+      then return UseUp+      else recursiveCall eff2+             -- no @execSfx@, because individual effects sent them++-- ** SeqEffect++effectSeqEffect :: forall m. MonadServerAtomic m+                => (IK.Effect -> m UseResult) -> [IK.Effect]+                -> m UseResult+effectSeqEffect recursiveCall effs = do+  mapM_ (void <$> recursiveCall) effs+  return UseUp+  -- no @execSfx@, because individual effects sent them++-- ** When++effectWhen :: forall m. MonadServerAtomic m+           => (IK.Effect -> m UseResult) -> ActorId+           -> IK.Condition -> IK.Effect -> ActivationFlag+           -> m UseResult+effectWhen recursiveCall source cond eff effActivation = do+  go <- conditionSem source cond effActivation+  if go then recursiveCall eff else return UseDud++-- ** Unless++effectUnless :: forall m. MonadServerAtomic m+             => (IK.Effect -> m UseResult) -> ActorId+             -> IK.Condition -> IK.Effect -> ActivationFlag+             -> m UseResult+effectUnless recursiveCall source cond eff effActivation = do+  go <- conditionSem source cond effActivation+  if not go then recursiveCall eff else return UseDud++-- ** IfThenElse++effectIfThenElse :: forall m. MonadServerAtomic m+                 => (IK.Effect -> m UseResult) -> ActorId+                 -> IK.Condition -> IK.Effect -> IK.Effect -> ActivationFlag+                 -> m UseResult+effectIfThenElse recursiveCall source cond eff1 eff2 effActivation = do+  c <- conditionSem source cond effActivation+  if c then recursiveCall eff1 else recursiveCall eff2++-- ** VerbNoLonger++effectVerbNoLonger :: MonadServerAtomic m+                   => Bool -> m () -> ActorId -> m UseResult+effectVerbNoLonger effUseAllCopies execSfx source = do+  b <- getsState $ getActorBody source+  when (effUseAllCopies  -- @UseUp@ ensures that if all used, all destroyed+        && not (bproj b))  -- no spam when projectiles activate+    execSfx  -- announce that all copies have run out (or whatever message)+  return UseUp  -- help to destroy the copy, even if not all used up++-- ** VerbMsg++effectVerbMsg :: MonadServerAtomic m => m () -> ActorId -> m UseResult+effectVerbMsg execSfx source = do+  b <- getsState $ getActorBody source+  unless (bproj b) execSfx  -- don't spam when projectiles activate+  return UseUp  -- announcing always successful and this helps+                -- to destroy the item++-- ** VerbMsgFail++effectVerbMsgFail :: MonadServerAtomic m => m () -> ActorId -> m UseResult+effectVerbMsgFail execSfx source = do+  b <- getsState $ getActorBody source+  unless (bproj b) execSfx  -- don't spam when projectiles activate+  return UseId  -- not @UseDud@ so that @OneOf@ doesn't ignore it
+ engine-src/Game/LambdaHack/Server/HandleRequestM.hs view
@@ -0,0 +1,1247 @@+-- | Semantics of requests+-- .+-- A couple of them do not take time, the rest does.+-- Note that since the results are atomic commands, which are executed+-- only later (on the server and some of the clients), all condition+-- are checkd by the semantic functions in the context of the state+-- before the server command. Even if one or more atomic actions+-- are already issued by the point an expression is evaluated, they do not+-- influence the outcome of the evaluation.+module Game.LambdaHack.Server.HandleRequestM+  ( handleRequestAI, handleRequestUI, handleRequestTimed, switchLeader+  , reqMoveGeneric, reqDisplaceGeneric, reqAlterFail+  , reqGameDropAndExit, reqGameSaveAndExit+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , execFailure, checkWaiting, processWatchfulness, affectStash+  , managePerRequest, handleRequestTimedCases, affectSmell+  , reqMove, reqMelee, reqMeleeChecked, reqDisplace, reqAlter+  , reqWait, reqWait10, reqYell, reqMoveItems, reqMoveItem, reqProject, reqApply+  , reqGameRestart, reqGameSave, reqDoctrine, reqAutomate+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import qualified Text.Show.Pretty as Show.Pretty++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client+  (ReqAI (..), ReqUI (..), RequestTimed (..))+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Analytics+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.TileKind as TK+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.CommonM+import           Game.LambdaHack.Server.HandleEffectM+import           Game.LambdaHack.Server.ItemM+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.PeriodicM+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++execFailure :: MonadServerAtomic m+            => ActorId -> RequestTimed -> ReqFailure -> m ()+execFailure aid req failureSer = do+  -- Clients should rarely do that (only in case of invisible actors)+  -- so we report it to the client, but do not crash+  -- (server should work OK with stupid clients, too).+  body <- getsState $ getActorBody aid+  let fid = bfid body+      msg = showReqFailure failureSer+      impossible = impossibleReqFailure failureSer+      debugShow :: Show a => a -> Text+      debugShow = T.pack . Show.Pretty.ppShow+      possiblyAlarm = if impossible+                      then debugPossiblyPrintAndExit+                      else debugPossiblyPrint+  possiblyAlarm $+    "Server: execFailure:" <+> msg <> "\n"+    <> debugShow body <> "\n" <> debugShow req <> "\n" <> debugShow failureSer+  execSfxAtomic $ SfxMsgFid fid $ SfxUnexpected failureSer++-- | The semantics of server commands.+-- AI always takes time and so doesn't loop.+handleRequestAI :: MonadServerAtomic m+                => ReqAI+                -> m (Maybe RequestTimed)+handleRequestAI cmd = case cmd of+  ReqAITimed cmdT -> return $ Just cmdT+  ReqAINop -> return Nothing++-- | The semantics of server commands. Only the first two cases affect time.+handleRequestUI :: MonadServerAtomic m+                => FactionId -> ActorId -> ReqUI+                -> m (Maybe RequestTimed)+handleRequestUI fid aid cmd = case cmd of+  ReqUITimed cmdT -> return $ Just cmdT+  ReqUIGameRestart t d -> reqGameRestart aid t d >> return Nothing+  ReqUIGameDropAndExit -> reqGameDropAndExit aid >> return Nothing+  ReqUIGameSaveAndExit -> reqGameSaveAndExit aid >> return Nothing+  ReqUIGameSave -> reqGameSave >> return Nothing+  ReqUIDoctrine toT -> reqDoctrine fid toT >> return Nothing+  ReqUIAutomate -> reqAutomate fid >> return Nothing+  ReqUINop -> return Nothing++checkWaiting :: RequestTimed -> Maybe Bool+checkWaiting cmd = case cmd of+  ReqWait -> Just True  -- true wait, with bracing, no overhead, etc.+  ReqWait10 -> Just False  -- false wait, only one clip at a time+  _ -> Nothing++-- | This is a shorthand. Instead of setting @bwatch@ in @ReqWait@+-- and unsetting in all other requests, we call this once after+-- executing a request.+-- In game state, we collect the number of server requests pertaining+-- to the actor (the number of actor's "moves"), through which+-- the actor was waiting.+processWatchfulness :: MonadServerAtomic m => Maybe Bool -> ActorId -> m ()+processWatchfulness mwait aid = do+  b <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let uneasy = deltasSerious (bcalmDelta b) || not (calmEnough b actorMaxSk)+  case bwatch b of+    WWatch ->+      when (mwait == Just True) $  -- only long wait switches to wait state+        if Ability.getSk Ability.SkWait actorMaxSk >= 2 then do+          addCondition False IK.S_BRACED aid+          execUpdAtomic $ UpdWaitActor aid WWatch (WWait 1)+        else+          execUpdAtomic $ UpdWaitActor aid WWatch (WWait 0)+    WWait 0 -> case mwait of  -- actor couldn't brace last time+      Just True -> return ()  -- if he still waits, keep him stuck unbraced+      _ -> execUpdAtomic $ UpdWaitActor aid (WWait 0) WWatch+    WWait n -> case mwait of+      Just True ->  -- only proper wait prevents switching to watchfulness+        if n >= 500 then  -- enough dozing to fall asleep+          if not uneasy  -- won't wake up at once+             && canSleep actorMaxSk  -- enough skills+          then do+            nAll <- removeConditionSingle IK.S_BRACED aid+            let !_A = assert (nAll == 0) ()+            addSleep aid+          else+            -- Start dozing from scratch to prevent hopeless skill checks.+            execUpdAtomic $ UpdWaitActor aid (WWait n) (WWait 1)+        else+          -- Doze some more before checking sleep eligibility.+          execUpdAtomic $ UpdWaitActor aid (WWait n) (WWait $ n + 1)+      _ -> do+        nAll <- removeConditionSingle IK.S_BRACED aid+        let !_A = assert (nAll == 0 `blame` nAll) ()+        execUpdAtomic $ UpdWaitActor aid (WWait n) WWatch+    WSleep ->+      if mwait /= Just False  -- lurk can't wake up regardless; too short+         && (isNothing mwait  -- not a wait+             || uneasy  -- spooked+             || not (deltaBenign $ bhpDelta b))  -- any HP lost+      then execUpdAtomic $ UpdWaitActor aid WSleep WWake+      else execUpdAtomic $ UpdRefillHP aid 10000+             -- no @xM@, so slow, but each turn HP gauge green;+             -- this is 1HP per 100 turns, so it's 10 times slower+             -- than a necklace that gives 1HP per 10 turns;+             -- so if an actor sleeps for the duration of a 1000 turns,+             -- which may be the time it takes to fully explore a level,+             -- 10HP would be gained, so weak actors would wake up twice over,+             -- which is fine: sleeping long enough to sidestep them at will,+             -- but attacking, e.g., a group with explosives, is good choice+             -- as well; so both stealth and mayhem fun correct tactically+    WWake -> unless (mwait == Just False) $  -- lurk can't wake up; too fast+      removeSleepSingle aid++-- Even very primitive actors that can't pick up items can take over stash,+-- to prevent them inadvertedly protecting enemy stash from skilled ones+-- by standing over it (which AI tends to do).+affectStash :: MonadServerAtomic m => Actor -> m ()+affectStash b = do+  let locateStash (fid, fact) = case gstash fact of+        Just (lidS, posS)+          | lidS == blid b && posS == bpos b && fid /= bfid b ->+            execUpdAtomic $ UpdLoseStashFaction True fid lidS posS+        _ -> return ()+  factionD <- getsState sfactionD+  mapM_ locateStash $ EM.assocs factionD++handleRequestTimed :: MonadServerAtomic m+                   => FactionId -> ActorId -> RequestTimed -> m Bool+handleRequestTimed fid aid cmd = do+  let mwait = checkWaiting cmd+  b <- getsState $ getActorBody aid+  -- Note that only the ordinary 1-turn wait eliminates overhead.+  -- The more fine-graned waits don't make actors braced and induce+  -- overhead, so that they have some drawbacks in addition to the+  -- benefit of seeing approaching danger up to almost a turn faster.+  -- It may be too late to block then, but not too late to sidestep or attack.+  unless (mwait == Just True) $ overheadActorTime fid (blid b)+  advanceTime aid (if mwait == Just False then 10 else 100) True+  handleRequestTimedCases aid cmd+  managePerRequest aid+  -- Note that due to the order, actor was still braced or sleeping+  -- throughout request processing, etc. So, if he hits himself kinetically,+  -- his armor from bracing previous turn is still in effect.+  processWatchfulness mwait aid+  return $! isNothing mwait  -- for speed, we report if @cmd@ harmless++-- | Clear deltas for Calm and HP for proper UI display and AI hints.+managePerRequest :: MonadServerAtomic m => ActorId -> m ()+managePerRequest aid = do+  b <- getsState $ getActorBody aid+  affectStash b+  let clearMark = 0+  unless (bcalmDelta b == ResDelta (0, 0) (0, 0)) $+    -- Clear delta for the next actor move.+    execUpdAtomic $ UpdRefillCalm aid clearMark+  unless (bhpDelta b == ResDelta (0, 0) (0, 0)) $+    -- Clear delta for the next actor move.+    execUpdAtomic $ UpdRefillHP aid clearMark++handleRequestTimedCases :: MonadServerAtomic m+                        => ActorId -> RequestTimed -> m ()+handleRequestTimedCases aid cmd = case cmd of+  ReqMove target -> reqMove aid target+  ReqMelee target iid cstore -> reqMelee aid target iid cstore+  ReqDisplace target -> reqDisplace aid target+  ReqAlter tpos -> reqAlter aid tpos+  ReqWait -> reqWait aid+  ReqWait10 -> reqWait10 aid+  ReqYell -> reqYell aid+  ReqMoveItems l -> reqMoveItems aid l+  ReqProject p eps iid cstore -> reqProject aid p eps iid cstore+  ReqApply iid cstore -> reqApply aid iid cstore++switchLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()+{-# INLINE switchLeader #-}+switchLeader fid aidNew = do+  fact <- getsState $ (EM.! fid) . sfactionD+  bPre <- getsState $ getActorBody aidNew+  let mleader = gleader fact+      !_A1 = assert (Just aidNew /= mleader+                     && not (bproj bPre)+                     `blame` (aidNew, bPre, fid, fact)) ()+      !_A2 = assert (bfid bPre == fid+                     `blame` "client tries to move other faction actors"+                     `swith` (aidNew, bPre, fid, fact)) ()+  let banned = bannedPointmanSwitchBetweenLevels fact+  arena <- case mleader of+    Nothing -> return $! blid bPre+    Just leader -> do+      b <- getsState $ getActorBody leader+      return $! blid b+  if blid bPre /= arena && banned  -- catch the cheating clients+  then execFailure aidNew ReqWait{-hack-} NoChangeDunLeader+  else do+    execUpdAtomic $ UpdLeadFaction fid mleader (Just aidNew)+    -- We exchange times of the old and new leader.+    -- This permits an abuse, because a slow tank can be moved fast+    -- by alternating between it and many fast actors (until all of them+    -- get slowed down by this and none remain). But at least the sum+    -- of all times of a faction is conserved. And we avoid double moves+    -- against the UI player caused by his leader changes. There may still+    -- happen double moves caused by AI leader changes, but that's rare.+    -- The flip side is the possibility of multi-moves of the UI player+    -- as in the case of the tank.+    -- Warning: when the action is performed on the server,+    -- the time of the actor is different than when client prepared that+    -- action, so any client checks involving time should discount this.+    case mleader of+      Just aidOld | aidOld /= aidNew -> swapTime aidOld aidNew+      _ -> return ()++-- * ReqMove++-- | Add a smell trace for the actor to the level. If smell already there+-- and the actor can smell, remove smell. Projectiles are ignored.+-- As long as an actor can smell, he doesn't leave any smell ever.+-- Smell trace is never left in water tiles.+affectSmell :: MonadServerAtomic m => ActorId -> m ()+affectSmell aid = do+  COps{coTileSpeedup} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let aquatic = Tile.isAquatic coTileSpeedup $ lvl `at` bpos b+  unless (bproj b || aquatic) $ do+    actorMaxSk <- getsState $ getActorMaxSkills aid+    let smellRadius = Ability.getSk Ability.SkSmell actorMaxSk+        hasOdor = Ability.getSk Ability.SkOdor actorMaxSk > 0+    when (hasOdor || smellRadius > 0) $ do+      localTime <- getsState $ getLocalTime $ blid b+      let oldS = fromMaybe timeZero $ EM.lookup (bpos b) . lsmell $ lvl+          newTime = timeShift localTime smellTimeout+          newS = if smellRadius > 0+                 then timeZero+                 else newTime+      when (oldS /= newS) $+        execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS++-- | Actor moves or attacks or alters by bumping.+-- Note that client may not be able to see an invisible monster+-- so it's the server that determines if melee took place, etc.+-- Also, only the server is authorized to check if a move is legal+-- and it needs full context for that, e.g., the initial actor position+-- to check if melee attack does not try to reach to a distant tile.+reqMove :: MonadServerAtomic m => ActorId -> Vector -> m ()+reqMove = reqMoveGeneric True True++reqMoveGeneric :: MonadServerAtomic m+               => Bool -> Bool -> ActorId -> Vector -> m ()+reqMoveGeneric voluntary mayAttack source dir = do+  COps{coTileSpeedup} <- getsState scops+  actorSk <- currentSkillsServer source+  sb <- getsState $ getActorBody source+  let abInSkill sk = isJust (btrajectory sb)+                     || Ability.getSk sk actorSk > 0+      lid = blid sb+  lvl <- getLevel lid+  let spos = bpos sb+      tpos = spos `shift` dir+  -- This predicate is symmetric wrt source and target, though the effect+  -- of collision may not be (the source projectiles applies its effect+  -- on the target particles, but loses 1 HP due to the collision).+  -- The condition implies that it's impossible to shoot down a bullet+  -- with a bullet, but a bullet can shoot down a burstable target,+  -- as well as be swept away by it, and two burstable projectiles+  -- burst when meeting mid-air. Projectiles that are not bursting+  -- nor damaging never collide with any projectile.+  collides <- getsState $ \s tb ->+    let sitemKind = getIidKindServer (btrunk sb) s+        titemKind = getIidKindServer (btrunk tb) s+        sar = sdiscoAspect s EM.! btrunk sb+        tar = sdiscoAspect s EM.! btrunk tb+        -- Such projectiles are prone to bursting or are themselves+        -- particles of an explosion shockwave.+        bursting arItem =+          IA.checkFlag Ability.Fragile arItem+          && IA.checkFlag Ability.Lobable arItem+        sbursting = bursting sar+        tbursting = bursting tar+        -- Such projectiles, even if not bursting themselves, can cause+        -- another projectile to burst.+        sdamaging = IK.isDamagingKind sitemKind+        tdamaging = IK.isDamagingKind titemKind+        -- Avoid explosion extinguishing itself via its own particles colliding.+        sameBlast = IA.checkFlag Ability.Blast sar+                    && getIidKindIdServer (btrunk sb) s+                       == getIidKindIdServer (btrunk tb) s+    in not sameBlast+       && (sbursting && (tdamaging || tbursting)+           || (tbursting && (sdamaging || sbursting)))+  -- We start by checking actors at the target position.+  tgt <- getsState $ posToAidAssocs tpos lid+  case tgt of+    (target, tb) : _ | mayAttack && (not (bproj sb)+                                     || not (bproj tb)+                                     || collides tb) -> do+      -- A projectile is too small and insubstantial to hit another projectile,+      -- unless it's large enough or tends to explode (fragile and lobable).+      -- The actor in the way is visible or not; server sees him always.+      -- Below the only weapon (the only item) of projectiles is picked.+      mweapon <- pickWeaponServer source target+      case mweapon of+        Just (wp, cstore) | abInSkill Ability.SkMelee ->+          reqMeleeChecked voluntary source target wp cstore+        _ -> return ()  -- waiting, even if no @SkWait@ skill+      -- Movement of projectiles only happens after melee and a check+      -- if they survive, so that if they don't, they explode in front+      -- of enemy, not under him, so that already first explosion blasts+      -- reach him, not only potential secondary explosions.+      when (bproj sb) $ do+        b2 <- getsState $ getActorBody source+        unless (actorDying b2) $ reqMoveGeneric voluntary False source dir+    _ ->+      -- Either the position is empty, or all involved actors are proj.+      -- Movement requires full access and skill.+      if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then+        if abInSkill Ability.SkMove then do+          execUpdAtomic $ UpdMoveActor source spos tpos+          affectSmell source+          -- No remote ransacking nor underfoot effects by projectiles,+          -- through which a projectile could cook its only item,+          -- but retain the old raw name and which would spam water+          -- slowness every time a projectile flies over water.+          unless (bproj sb) $+            -- Counts as bumping, because terrain transformation probably+            -- not intended, because the goal was probably just to move+            -- and then modifying the terrain is an unwelcome side effect.+            -- Barged into a tile, so normal effects need to activate,+            -- while crafting requires explicit altering.+            void $ reqAlterFail True EffBare voluntary source tpos+       else execFailure source (ReqMove dir) MoveUnskilled+      else do+        -- If not walkable, this must be altering by bumping.+        -- If voluntary then probably intentional so report any errors.+        mfail <- reqAlterFail True EffBare voluntary source tpos+        when voluntary $ do+          let req = ReqMove dir+          maybe (return ()) (execFailure source req) mfail++-- * ReqMelee++-- | Resolves the result of an actor moving into another.+-- Actors on unwalkable positions can be attacked without any restrictions.+-- For instance, an actor embedded in a wall can be attacked from+-- an adjacent position. This function is analogous to projectGroupItem,+-- but for melee and not using up the weapon.+-- No problem if there are many projectiles at the spot. We just+-- attack the one specified.+reqMelee :: MonadServerAtomic m+         => ActorId -> ActorId -> ItemId -> CStore -> m ()+reqMelee source target iid cstore = do+  actorSk <- currentSkillsServer source+  if Ability.getSk Ability.SkMelee actorSk > 0 then+    reqMeleeChecked True source target iid cstore+  else execFailure source (ReqMelee target iid cstore) MeleeUnskilled++reqMeleeChecked :: forall m. MonadServerAtomic m+                => Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()+reqMeleeChecked voluntary source target iid cstore = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  discoAspect <- getsState sdiscoAspect+  let req = ReqMelee target iid cstore+      arWeapon = discoAspect EM.! iid+      meleeableEnough = bproj sb || IA.checkFlag Ability.Meleeable arWeapon+  if source == target then execFailure source req MeleeSelf+  else if not (checkAdjacent sb tb) then execFailure source req MeleeDistant+  else if not meleeableEnough then execFailure source req MeleeNotWeapon+  else do+    -- If @voluntary@ is set, blame is exact, otherwise, an approximation.+    killer <- if | voluntary -> assert (not (bproj sb)) $ return source+                 | bproj sb -> getsServer $ EM.findWithDefault source source+                               . strajPushedBy+                 | otherwise -> return source+    actorSk <- currentSkillsServer source+    let arTrunk = discoAspect EM.! btrunk tb+        sfid = bfid sb+        tfid = bfid tb+        -- Let the missile drop down, but don't remove its trajectory+        -- so that it doesn't pretend to have hit a wall.+        haltTrajectory :: KillHow -> ActorId -> Actor -> m ()+        haltTrajectory killHow aid b = case btrajectory b of+          btra@(Just (l, speed)) | not $ null l -> do+            execUpdAtomic $ UpdTrajectory aid btra $ Just ([], speed)+            let arTrunkAid = discoAspect EM.! btrunk b+            when (bproj b && not (IA.checkFlag Ability.Blast arTrunkAid)) $+              addKillToAnalytics killer killHow (bfid b) (btrunk b)+          _ -> return ()+    -- Only catch if braced. Never steal trunk from an already caught+    -- projectile or one with many items inside.+    if bproj tb+       && EM.size (beqp tb) == 1+       && not (IA.checkFlag Ability.Blast arTrunk)+       && actorWaits sb  -- still valid while request being processed+       && Ability.getSk Ability.SkMoveItem actorSk > 0  -- animals can't+    then do+      -- Catching the projectile, that is, stealing the item from its eqp.+      -- No effect from our weapon (organ) is applied to the projectile+      -- and the weapon (organ) is never destroyed, even if not durable.+      -- Pushed actor doesn't stop flight by catching the projectile+      -- nor does he lose 1HP.+      -- This is not overpowered, because usually at least one partial wait+      -- is needed to sync (if not, attacker should switch missiles)+      -- and so only every other missile can be caught. Normal sidestepping+      -- or sync and displace, if in a corridor, is as effective+      -- and blocking can be even more so, depending on powers of the missile.+      -- Missiles are really easy to defend against, but sight (and so, Calm)+      -- is the key, as well as light, ambush around a corner, etc.+      execSfxAtomic $ SfxSteal source target iid+      case EM.assocs $ beqp tb of+        [(iid2, (k, _))] -> do+          upds <- generalMoveItem True iid2 k (CActor target CEqp)+                                              (CActor source CStash)+          mapM_ execUpdAtomic upds+          itemFull <- getsState $ itemToFull iid2+          discoverIfMinorEffects (CActor source CStash)+                                 iid2 (itemKindId itemFull)+        err -> error $ "" `showFailure` err+      haltTrajectory KillCatch target tb+    else do+      if bproj sb && bproj tb then do+        -- Special case for collision of projectiles, because they just+        -- symmetrically ram into each other, so picking one to hit another,+        -- based on random timing, would be wrong.+        -- Instead of suffering melee attack, let the target projectile+        -- get smashed and burst (if fragile and if not piercing).+        -- The source projectile terminates flight (unless pierces) later on.+        when (bhp tb > oneM) $+          execUpdAtomic $ UpdRefillHP target minusM+        when (bhp tb <= oneM) $ do+          -- If projectile has too low HP to pierce, terminate its flight.+          let killHow | IA.checkFlag Ability.Blast arWeapon = KillKineticBlast+                      | otherwise = KillKineticRanged+          haltTrajectory killHow target tb+        -- Avoid spam when two explosions collide.+        unless (IA.checkFlag Ability.Blast arWeapon+                && IA.checkFlag Ability.Blast arTrunk) $+          execSfxAtomic $ SfxStrike source target iid+      else do+        -- Normal hit, with effects, but first auto-apply defences.+        let mayDestroyTarget = not (bproj tb) || bhp tb <= oneM+            effApplyFlagsTarget = EffApplyFlags+              { effToUse            = EffBare+              , effVoluntary        = voluntary+              , effUseAllCopies     = False+              , effKineticPerformed = False+              , effActivation       = if bproj sb+                                      then Ability.ActivationUnderRanged+                                      else Ability.ActivationUnderMelee+              , effMayDestroy       = mayDestroyTarget+              }+        unless (bproj tb) $+          autoApply effApplyFlagsTarget killer target tb+          $ if bproj sb then Ability.UnderRanged else Ability.UnderMelee+        -- This might have changed the actors.+        sb2 <- getsState $ getActorBody source+        targetMaxSk <- getsState $ getActorMaxSkills target+        if | bproj sb2+             && Ability.getSk Ability.SkDeflectRanged targetMaxSk > 0 -> do+               cutCalm target+               execSfxAtomic $ SfxRecoil source target iid+           | Ability.getSk Ability.SkDeflectMelee targetMaxSk > 0 -> do+               cutCalm target+               execSfxAtomic $ SfxRecoil source target iid+           | otherwise -> do+               -- Msgs inside @SfxStrike@ describe the source part+               -- of the strike.+               execSfxAtomic $ SfxStrike source target iid+               let c = CActor source cstore+                   mayDestroySource = not (bproj sb2) || bhp sb2 <= oneM+                     -- piercing projectiles may not have their weapon destroyed+               -- Msgs inside @itemEffect@ describe the target part+               -- of the strike.+               -- If any effects and aspects, this is also where they are+               -- identified.+               -- Here also the kinetic damage is applied,+               -- before any effects are.+               --+               -- Note: that "hornet swarm detect items" via a scrolls+               -- is intentional,+               -- even though unrealistic and funny. Otherwise actors+               -- could protect+               -- themselves from some projectiles by lowering their apply stat.+               -- Also, the animal faction won't have too much benefit+               -- from that info,+               -- so the problem is not balance, but the goofy message.+               let effApplyFlagsSource = EffApplyFlags+                     { effToUse            = EffBare+                     , effVoluntary        = voluntary+                     , effUseAllCopies     = False+                     , effKineticPerformed = False+                     , effActivation       = Ability.ActivationMeleeable+                     , effMayDestroy       = mayDestroySource+                     }+               void $ kineticEffectAndDestroy effApplyFlagsSource killer+                                              source target iid c+      sb2 <- getsState $ getActorBody source+      case btrajectory sb2 of+        Just{} | not voluntary -> do+          -- Deduct a hitpoint for a pierce of a projectile+          -- or due to a hurled actor colliding with another (seen from+          -- @voluntary@, as opposed to hurled actor actively meleeing another).+          -- Don't deduct if no pierce, to prevent spam.+          -- Never kill in this way.+          when (bhp sb2 > oneM) $ do+            execUpdAtomic $ UpdRefillHP source minusM+            unless (bproj sb2) $ do+              execSfxAtomic $+                SfxMsgFid (bfid sb2) $ SfxCollideActor source target+              unless (bproj tb) $+                execSfxAtomic $+                  SfxMsgFid (bfid tb) $ SfxCollideActor source target+          when (not (bproj sb2) || bhp sb2 <= oneM) $+            -- Non-projectiles can't pierce, so terminate their flight.+            -- If projectile has too low HP to pierce, ditto.+            haltTrajectory KillActorLaunch source sb2+        _ -> return ()+      -- The only way to start a war is to slap an enemy voluntarily..+      -- Being hit by and hitting projectiles, as well as via pushing,+      -- count as unintentional friendly fire.+      sfact <- getsState $ (EM.! sfid) . sfactionD+      let friendlyFire = bproj sb2 || bproj tb || not voluntary+          fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)+      unless (friendlyFire+              || isFoe sfid sfact tfid  -- already at war+              || isFriend sfid sfact tfid) $  -- allies never at war+        execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War++autoApply :: MonadServerAtomic m+          => EffApplyFlags -> ActorId -> ActorId -> Actor -> Ability.Flag+          -> m ()+autoApply effApplyFlags killer target tb flag = do+  let autoApplyIid c iid = do+        itemFull <- getsState $ itemToFull iid+        let arItem = aspectRecordFull itemFull+        when (IA.checkFlag flag arItem) $+          void $ effectAndDestroyAndAddKill effApplyFlags killer target target+                                            iid c itemFull+  mapM_ (autoApplyIid $ CActor target CEqp) $ EM.keys $ beqp tb+  mapM_ (autoApplyIid $ CActor target COrgan) $ EM.keys $ borgan tb++-- * ReqDisplace++-- | Actor tries to swap positions with another.+reqDisplace :: MonadServerAtomic m => ActorId -> ActorId -> m ()+reqDisplace = reqDisplaceGeneric True++reqDisplaceGeneric :: MonadServerAtomic m => Bool -> ActorId -> ActorId -> m ()+reqDisplaceGeneric voluntary source target = do+  COps{coTileSpeedup} <- getsState scops+  actorSk <- currentSkillsServer source+  sb <- getsState $ getActorBody source+  let abInSkill sk = isJust (btrajectory sb)+                     || Ability.getSk sk actorSk > 0+  tb <- getsState $ getActorBody target+  tfact <- getsState $ (EM.! bfid tb) . sfactionD+  let spos = bpos sb+      tpos = bpos tb+      atWar = isFoe (bfid tb) tfact (bfid sb)+      req = ReqDisplace target+  actorMaxSk <- getsState $ getActorMaxSkills target+  dEnemy <- getsState $ dispEnemy source target actorMaxSk+  if | not (abInSkill Ability.SkDisplace) ->+         execFailure source req DisplaceUnskilled+     | not (checkAdjacent sb tb) -> execFailure source req DisplaceDistant+     | atWar && not dEnemy -> do  -- if not at war, can displace always+       -- We don't fail with DisplaceImmobile and DisplaceSupported.+       -- because it's quite common they can't be determined by the attacker,+       -- and so the failure would be too alarming to the player.+       -- If the character melees instead, the player can tell displace failed.+       -- As for the other failures, they are impossible and we don't+       -- verify here that they don't occur, for simplicity.+       mweapon <- pickWeaponServer source target+       case mweapon of+         Just (wp, cstore) | abInSkill Ability.SkMelee ->+           reqMeleeChecked voluntary source target wp cstore+         _ -> return ()  -- waiting, even if no @SkWait@ skill+     | otherwise -> do+       let lid = blid sb+       lvl <- getLevel lid+       -- Displacing requires full access.+       if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then+         case posToAidsLvl tpos lvl of+           [] -> error $ "" `showFailure` (source, sb, target, tb)+           [_] -> do+             execUpdAtomic $ UpdDisplaceActor source target+             -- We leave or wipe out smell, for consistency, but it's not+             -- absolute consistency, e.g., blinking doesn't touch smell,+             -- so sometimes smellers will backtrack once to wipe smell. OK.+             affectSmell source+             affectSmell target+             -- Counts as bumping, because terrain transformation not intended.+             void $ reqAlterFail True EffBare False source tpos+               -- possibly alter or activate+             void $ reqAlterFail True EffBare False target spos+           _ -> execFailure source req DisplaceMultiple+       else+         -- Client foolishly tries to displace an actor without access.+         execFailure source req DisplaceAccess++-- * ReqAlter++-- | Search and/or alter the tile.+reqAlter :: MonadServerAtomic m => ActorId -> Point -> m ()+reqAlter source tpos = do+  COps{coTileSpeedup} <- getsState scops+  sb <- getsState $ getActorBody source+  lvl <- getLevel $ blid sb+  -- This is explicit tile triggering. Walkable tiles are sparse enough+  -- that crafting effects can be activated without any others+  -- and without changing the tile and this is usually beneficial,+  -- so always attempted. OTOH, squeezing a hand into a non-walkable tile+  -- or barging into walkable tiles (but not as a projectile) activates all.+  let effToUse = if Tile.isWalkable coTileSpeedup (lvl `at` tpos)+                 then EffOnCombine+                 else EffBareAndOnCombine+  mfail <- reqAlterFail False effToUse True source tpos+  let req = ReqAlter tpos+  maybe (return ()) (execFailure source req) mfail++reqAlterFail :: forall m. MonadServerAtomic m+             => Bool -> EffToUse -> Bool -> ActorId -> Point+             -> m (Maybe ReqFailure)+reqAlterFail bumping effToUse voluntary source tpos = do+  cops@COps{cotile, coTileSpeedup, corule} <- getsState scops+  sb <- getsState $ getActorBody source+  actorMaxSk <- getsState $ getActorMaxSkills source+  let calmE = calmEnough sb actorMaxSk+      lid = blid sb+  sClient <- getsServer $ (EM.! bfid sb) . sclientStates+  itemToF <- getsState $ flip itemToFull+  actorSk <- currentSkillsServer source+  localTime <- getsState $ getLocalTime lid+  embeds <- getsState $ getEmbedBag lid tpos+  lvl <- getLevel lid+  getKind <- getsState $ flip getIidKindServer+  let serverTile = lvl `at` tpos+      lvlClient = (EM.! lid) . sdungeon $ sClient+      clientTile = lvlClient `at` tpos+      hiddenTile = Tile.hideAs cotile serverTile+      alterSkill = Ability.getSk Ability.SkAlter actorSk+      tileMinSkill = Tile.alterMinSkill coTileSpeedup serverTile+      revealEmbeds = unless (EM.null embeds) $+        execUpdAtomic $ UpdSpotItemBag True (CEmbed lid tpos) embeds+      embedKindList =+        map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds)+      sbItemKind = getKind $ btrunk sb+      -- Prevent embeds triggering each other's exploding embeds+      -- via feeble mists, in the worst case, in a loop. However,+      -- if a tile can be changed with an item (e.g., the mist trunk)+      -- but without activating embeds, mists do fine.+      projNoDamage = bproj sb && not (IK.isDamagingKind sbItemKind)+      tryApplyEmbed (iid, kit) = do+        let itemFull = itemToF iid+            -- Let even completely apply-unskilled actors trigger basic embeds.+            -- See the note about no skill check when melee triggers effects.+            legal = permittedApply corule localTime maxBound calmE Nothing+                                   itemFull kit+        case legal of+          Left ApplyNoEffects -> return UseDud  -- pure flavour embed+          Left reqFail -> do+            -- The failure is fully expected, because client may choose+            -- to trigger some embeds, knowing that others won't fire.+            execSfxAtomic $ SfxMsgFid (bfid sb)+                          $ SfxExpectedEmbed iid lid reqFail+            return UseDud+          _ -> itemEffectEmbedded effToUse voluntary source lid tpos iid+                 -- when @effToUse == EffOnCombine@, terrain, e.g., fire,+                 -- may be removed safely, without adverse effects+                 -- by crafting, even any silly crafting as an exploit; OK+      underFeet = tpos == bpos sb  -- if enter and alter, be more permissive+      blockedByItem = EM.member tpos (lfloor lvl)+  if chessDist tpos (bpos sb) > 1+  then return $ Just AlterDistant+  else if Just clientTile == hiddenTile then  -- searches+    -- Only non-projectile actors with SkAlter > 1 can search terrain.+    -- Even projectiles with large altering bonuses can't.+    if bproj sb || not underFeet && alterSkill <= 1+    then return $ Just AlterUnskilled  -- don't leak about searching+    else do+      -- Blocking by items nor actors does not prevent searching.+      -- Searching broadcasted, in case actors from other factions are present+      -- so that they can learn the tile and learn our action.+      -- If they already know the tile, they will just consider our action+      -- a waste of time and ignore the command.+      execUpdAtomic $ UpdSearchTile source tpos serverTile+      -- Searching also reveals the embedded items of the tile.+      -- If the items are already seen by the client+      -- (e.g., due to item detection, despite tile being still hidden),+      -- the command is ignored on the client.+      revealEmbeds+      -- If the entries are already seen by the client+      -- the command is ignored on the client.+      case EM.lookup tpos $ lentry lvl of+        Nothing -> return ()+        Just entry -> execUpdAtomic $ UpdSpotEntry lid [(tpos, entry)]+      -- Seaching triggers the embeds as well, after they are revealed.+      -- The rationale is that the items were all the time present+      -- (just invisible to the client), so they need to be triggered.+      -- The exception is changable tiles, because they are not so easy+      -- to trigger; they need previous or subsequent altering.+      unless (Tile.isModifiable coTileSpeedup serverTile || projNoDamage) $+        mapM_ (void <$> tryApplyEmbed)+              (sortEmbeds cops serverTile embedKindList)+      return Nothing  -- searching is always success+  else+    -- Here either @clientTile == serverTile@ or the client+    -- is misguided re tile at that position, e.g., it is a projectile+    -- that can't see the tile and the tile was not revealed so far.+    -- In either case, try to alter the tile. If the messages+    -- are confusing, that's fair, situation is confusing.+    if not (bproj sb || underFeet)  -- no global skill check in these cases+       && alterSkill < tileMinSkill+    then return $ Just AlterUnskilled  -- don't leak about altering+    else do+      -- Save the original content of ground and eqp to abort transformations+      -- if any item is removed, possibly an item intended as the fuel.+      groundBag <- getsState $ getBodyStoreBag sb CGround+      eqpBag <- getsState $ getBodyStoreBag sb CEqp+      -- Compute items to use for transformation early, before any extra+      -- items added by activated embeds, to use only intended items as fuel.+      -- Use even unidentified items --- one more way to id by use.+      kitAssG <- getsState $ kitAssocs source [CGround]+      kitAssE <- getsState $ kitAssocs source [CEqp]+      let kitAss = listToolsToConsume kitAssG kitAssE+          announceTileChange =+            -- If no embeds and the only thing that happens is the change+            -- of the tile, don't display a message, because the change+            -- is visible on the map (unless it changes into itself)+            -- and there's nothing more to speak about.+            -- However, even with embeds, don't spam if wading through+            -- terrain and changing it each step.+            unless (underFeet || EM.null embeds) $+              execSfxAtomic $ SfxTrigger source lid tpos serverTile+          changeTo tgroup = do+            -- No @SfxAlter@, because the effect is obvious (e.g., opened door).+            let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt+                                    && Tile.kindHasFeature TK.Clear kt)+                               || (if lnight lvl then id else not)+                                    (Tile.kindHasFeature TK.Dark kt)+            -- Sometimes the tile is determined precisely by the ambient light+            -- of the source tiles. If not, default to cave day/night condition.+            mtoTile <- rndToAction $ opick cotile tgroup nightCond+            toTile <- maybe (rndToAction+                             $ fromMaybe (error $ "" `showFailure` tgroup)+                               <$> opick cotile tgroup (const True))+                            return+                            mtoTile+            embeds2 <- getsState $ getEmbedBag lid tpos+            let newHasEmbeds = Tile.isEmbed coTileSpeedup toTile+            -- Don't regenerate same tile, unless it had embeds, but all spent.+            when (serverTile /= toTile+                  || EM.null embeds2 && newHasEmbeds) $ do+              -- At most one of these two will be accepted on any given client.+              when (serverTile /= toTile) $+                execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile+              -- This case happens when a client does not see a searching+              -- action by another faction, but sees the subsequent altering+              -- or if another altering takes place in between.+              case hiddenTile of+                Just tHidden ->+                  execUpdAtomic $ UpdAlterTile lid tpos tHidden toTile+                Nothing -> return ()+              -- @UpdAlterExplorable@ is received by any client regardless+              -- of whether the alteration was seen and how.+              case (Tile.isExplorable coTileSpeedup serverTile,+                    Tile.isExplorable coTileSpeedup toTile) of+                (False, True) -> execUpdAtomic $ UpdAlterExplorable lid 1+                (True, False) -> execUpdAtomic $ UpdAlterExplorable lid (-1)+                _ -> return ()+              -- At the end we replace old embeds (even if partially used up)+              -- with new ones.+              -- If the source tile was hidden, the items could not be visible+              -- on a client, in which case the command would be ignored+              -- on the client, without causing any problems. Otherwise,+              -- if the position is in view, client has accurate info.+              unless (EM.null embeds2) $+                execUpdAtomic $ UpdLoseItemBag True (CEmbed lid tpos) embeds2+              -- Altering always reveals the outcome tile, so it's not hidden+              -- and so its embedded items are always visible.+              embedItemOnPos lid tpos toTile+          tryChangeWith :: ( [(Int, GroupName IK.ItemKind)]+                           , GroupName TK.TileKind )+                        -> m Bool+          tryChangeWith (tools0, tgroup) = do+            let grps0 = map (\(x, y) -> (False, x, y)) tools0+                  -- apply if durable+                (bagsToLose, iidsToApply, grps) =+                  foldl' subtractIidfromGrps (EM.empty, [], grps0) kitAss+            if null grps then do+              announceTileChange  -- first the result is foretold+              consumeItems source bagsToLose iidsToApply  -- then the cost+              changeTo tgroup  -- then result is seen+              return True+            else return False+          feats = TK.tfeature $ okind cotile serverTile+          tileActions =+            mapMaybe (parseTileAction+                        (bproj sb)+                        (underFeet || blockedByItem)  -- avoids AlterBlockItem+                        embedKindList)+                     feats+          groupWithFromAction action = case action of+            WithAction grps _ | not bumping -> Just grps+            _ -> Nothing+          groupsToAlterWith = mapMaybe groupWithFromAction tileActions+          processTileActions :: Maybe UseResult -> [TileAction] -> m Bool+          processTileActions museResult [] =+            return $! maybe False (/= UseDud) museResult+          processTileActions museResult (ta : rest) = case ta of+            EmbedAction (iid, kit) ->+              -- Embeds are activated in the order in tile definition+              -- and never after the tile is changed.+              -- If any embedded item was present and processed,+              -- but none was triggered, both free and item-consuming terrain+              -- alteration is disabled. The exception is projectiles+              -- not being able to process embeds due to skill required,+              -- which does not block future terrain alteration.+              -- Skill check for non-projectiles is performed much earlier.+              -- All projectiles have 0 skill for the purpose of embed+              -- activation, regardless of their trunk.+              if | bproj sb && tileMinSkill > 0 ->  -- local skill check+                   processTileActions museResult rest+                     -- not blocking future terrain altering, e.g., oil mist+                     -- not slowed over water tile that has @talter@ equal to 2,+                     -- but able to change it into oil spill soon after+                 | projNoDamage ->+                   processTileActions (Just UseDud) rest+                     -- projectiles having enough skill, but no damage,+                     -- not only can't activate embeds, but block future+                     -- terrain altering, e.g., oil mist not puncturing+                     -- a barrel and causing explosion, and so also+                     -- not causing it to disappear later on+                 | otherwise -> do+                     -- here falls the case of fragmentation blast puncturing+                     -- a barrel and so causing an explosion+                     triggered <- tryApplyEmbed (iid, kit)+                     let useResult = fromMaybe UseDud museResult+                     processTileActions (Just $ max useResult triggered) rest+                       -- max means that even one activated embed is enough+                       -- to alter terrain in a future action+            ToAction tgroup -> assert (not (bproj sb)) $+              -- @parseTileAction@ ensures the above assertion+              -- so that projectiles never cause normal transitions and,+              -- e.g., mists douse fires or two flames thrown, first ignites,+              -- second douses immediately afterwards+              if maybe True (== UseUp) museResult+              then do+                announceTileChange+                changeTo tgroup+                return True+              else processTileActions museResult rest+            WithAction grps tgroup -> do+              -- Note that there is no skill check if the source actors+              -- is a projectile. Permission is conveyed in @ProjYes@ instead.+              groundBag2 <- getsState $ getBodyStoreBag sb CGround+              eqpBag2 <- getsState $ getBodyStoreBag sb CEqp+              if (not bumping || null grps)+                   -- 'M' confirmation needed to consume items, bump not enough+                 && (bproj sb || voluntary || null grps)+                       -- consume only if voluntary or released as projectile+                 && (maybe True (== UseUp) museResult+                     || effToUse == EffOnCombine)+                          -- unwanted crafting shouldn't block transformations+                 && let f (k1, _) (k2, _) = k1 <= k2+                    in EM.isSubmapOfBy f groundBag groundBag2+                       && EM.isSubmapOfBy f eqpBag eqpBag2+                      -- don't transform if items, possibly intended for+                      -- transformation, removed; also when only crafting+                      -- was intended, which almost always removes some items+              then do+                altered <- tryChangeWith (grps, tgroup)+                if altered+                then return True+                else processTileActions museResult rest+              else processTileActions museResult rest+      -- Note that stray embedded items (not from tile content definition)+      -- are never activated.+      if null tileActions then+        return $! if blockedByItem+                     && not underFeet+                     && Tile.isModifiable coTileSpeedup serverTile+                  then Just AlterBlockItem  -- likely cause+                  else Just AlterNothing  -- can't do; silly client; fail+      else+        if underFeet || not (occupiedBigLvl tpos lvl)+                        && not (occupiedProjLvl tpos lvl) then do+          -- The items are first revealed for the sake of clients that+          -- may see the tile as hidden. Note that the tile is not revealed+          -- (unless it's altered later on, in which case the new one is).+          revealEmbeds+          tileTriggered <- processTileActions Nothing tileActions+          let potentiallyMissing = filter (not . null) groupsToAlterWith+          when (not tileTriggered && not underFeet && voluntary+                && not (null potentiallyMissing)) $+            execSfxAtomic $ SfxMsgFid (bfid sb)+                          $ SfxNoItemsForTile potentiallyMissing+          return Nothing  -- altered as much as items allowed; success+        else return $ Just AlterBlockActor++-- * ReqWait++-- | Do nothing. Wait skill 1 required. Bracing requires 2, sleep 3, lurking 4.+--+-- Something is sometimes done in 'processWatchfulness'.+reqWait :: MonadServerAtomic m => ActorId -> m ()+{-# INLINE reqWait #-}+reqWait source = do+  actorSk <- currentSkillsServer source+  unless (Ability.getSk Ability.SkWait actorSk > 0) $+    execFailure source ReqWait WaitUnskilled++-- * ReqWait10++-- | Do nothing.+--+-- Something is sometimes done in 'processWatchfulness'.+reqWait10 :: MonadServerAtomic m => ActorId -> m ()+{-# INLINE reqWait10 #-}+reqWait10 source = do+  actorSk <- currentSkillsServer source+  unless (Ability.getSk Ability.SkWait actorSk >= 4) $+    execFailure source ReqWait10 WaitUnskilled++-- * ReqYell++-- | Yell/yawn/stretch/taunt.+-- Wakes up (gradually) from sleep. Causes noise heard by enemies on the level+-- even if out of their hearing range.+--+-- Governed by the waiting skill (because everyone is supposed to have it).+-- unlike @ReqWait@, induces overhead.+--+-- This is similar to the effect @Yell@, but always voluntary.+reqYell :: MonadServerAtomic m => ActorId -> m ()+reqYell aid = do+  actorSk <- currentSkillsServer aid+  if | Ability.getSk Ability.SkWait actorSk > 0 ->+       -- Last yawn before waking up is displayed as a yell, but that's fine.+       -- To fix that, we'd need to move the @SfxTaunt@+       -- to @processWatchfulness@.+       execSfxAtomic $ SfxTaunt True aid+     | Ability.getSk Ability.SkMove actorSk <= 0+       || Ability.getSk Ability.SkDisplace actorSk <= 0+       || Ability.getSk Ability.SkMelee actorSk <= 0 ->+       -- Potentially, only waiting is possible, so given that it's drained,+       -- don't let the actor be stuck nor alarm about server failure.+       execSfxAtomic $ SfxTaunt False aid+     | otherwise -> do+       -- In most situation one of the 3 actions above+       -- can be performed and waiting skill is not needed for that,+       -- so given the 3 skills are available, waste turn, waiting until+       -- they can be performed, but don't alarm, because it does happen+       -- sometimes in crowds. No bracing granted, either, but mark+       -- waiting so that AI knows to change leader.+       --   execFailure aid ReqYell YellUnskilled+       b <- getsState $ getActorBody aid+       case bwatch b of+         WWait _ -> return ()+         _ -> execUpdAtomic $ UpdWaitActor aid (bwatch b) (WWait 0)++-- * ReqMoveItems++reqMoveItems :: MonadServerAtomic m+             => ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()+reqMoveItems source l = do+  actorSk <- currentSkillsServer source+  if Ability.getSk Ability.SkMoveItem actorSk > 0 then do+    b <- getsState $ getActorBody source+    actorMaxSk <- getsState $ getActorMaxSkills source+    -- Server accepts item movement based on calm at the start, not end+    -- or in the middle, to avoid interrupted or partially ignored commands.+    let calmE = calmEnough b actorMaxSk+    case l of+      [] -> execFailure source (ReqMoveItems l) ItemNothing+      iid : rest -> do+        reqMoveItem False source calmE iid+        -- Dropping previous may destroy next items.+        mapM_ (reqMoveItem True source calmE) rest+  else execFailure source (ReqMoveItems l) MoveItemUnskilled++reqMoveItem :: MonadServerAtomic m+            => Bool -> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()+reqMoveItem absentPermitted aid calmE (iid, kOld, fromCStore, toCStore) = do+  b <- getsState $ getActorBody aid+  let fromC = CActor aid fromCStore+      req = ReqMoveItems [(iid, kOld, fromCStore, toCStore)]+  toC <- case toCStore of+    CGround -> pickDroppable False aid b  -- drop over fog, etc.+    _ -> return $! CActor aid toCStore+  bagFrom <- getsState $ getContainerBag (CActor aid fromCStore)+  bagBefore <- getsState $ getContainerBag toC+  -- The effect of dropping previous items from this series may have+  -- increased or decreased the number of this item.+  let k = min kOld $ fst $ EM.findWithDefault (0, []) iid bagFrom+  let !_A = absentPermitted || k == kOld+  if+   | absentPermitted && k == 0 -> return ()+   | k < 1 || fromCStore == toCStore -> execFailure aid req ItemNothing+   | fromCStore == CEqp && not calmE ->+     execFailure aid req ItemNotCalm+   | toCStore == CEqp && not calmE ->+     execFailure aid req ItemNotCalm+   | toCStore == CEqp && eqpOverfull b k ->+     execFailure aid req EqpOverfull+   | otherwise -> do+    upds <- generalMoveItem True iid k fromC toC+    mapM_ execUpdAtomic upds+    itemFull <- getsState $ itemToFull iid+    -- Let any item manipulation attempt to identify, in case the item+    -- got into stash, e.g., by being thrown at the stash location,+    -- and gets identified only when equipped or dropped and picked up again.+    discoverIfMinorEffects toC iid (itemKindId itemFull)+    -- The first recharging period after equipping is random,+    -- between 1 and 2 standard timeouts of the item.+    -- Timeouts for items in shared stash are not consistent wrt the actor's+    -- local time, because actors from many levels put items there+    -- all the time (and don't rebase it to the clock of the stash's level).+    -- If wrong local time in shared stash causes an item to recharge+    -- for a very long time wrt actor on some level,+    -- the player can reset it by dropping the item and picking up again+    -- (as a flip side, a charging item in stash may sometimes+    -- be used at once on another level, with different local time, but only+    -- once, because after first use, the timeout is set to local time).+    -- This is not terribly consistent, but not recharging in stash is+    -- not better, because either we block activation of any items with timeout,+    -- or encourage moving items out of stash, recharging and moving in.+    -- Which is not fun at all, but one more thing to remember doing regularly.+    when (toCStore `elem` [CEqp, COrgan]+          && fromCStore `notElem` [CEqp, COrgan]+          || fromCStore == CStash) $ do+      let beforeIt = case iid `EM.lookup` bagBefore of+            Nothing -> []  -- no such items before move+            Just (_, it2) -> it2+      randomResetTimeout k iid itemFull beforeIt toC++-- * ReqProject++reqProject :: MonadServerAtomic m+           => ActorId    -- ^ actor projecting the item (is on current lvl)+           -> Point      -- ^ target position of the projectile+           -> Int        -- ^ digital line parameter+           -> ItemId     -- ^ the item to be projected+           -> CStore     -- ^ which store the items comes from+           -> m ()+reqProject source tpxy eps iid cstore = do+  let req = ReqProject tpxy eps iid cstore+  b <- getsState $ getActorBody source+  curChalSer <- getsServer $ scurChalSer . soptions+  fact <- getsState $ (EM.! bfid b) . sfactionD+  actorMaxSk <- getsState $ getActorMaxSkills source+  let calmE = calmEnough b actorMaxSk+  if | ckeeper curChalSer && fhasUI (gkind fact) ->+        execFailure source req ProjectFinderKeeper+     | cstore == CEqp && not calmE -> execFailure source req ItemNotCalm+     | otherwise -> do+         mfail <-+           projectFail source source (bpos b) tpxy eps False iid cstore False+         maybe (return ()) (execFailure source req) mfail++-- * ReqApply++reqApply :: MonadServerAtomic m+         => ActorId  -- ^ actor applying the item (is on current level)+         -> ItemId   -- ^ the item to be applied+         -> CStore   -- ^ the location of the item+         -> m ()+reqApply aid iid cstore = do+  COps{corule} <- getsState scops+  let req = ReqApply iid cstore+  b <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let calmE = calmEnough b actorMaxSk+  if cstore == CEqp && not calmE then execFailure aid req ItemNotCalm+  else do+    bag <- getsState $ getBodyStoreBag b cstore+    case EM.lookup iid bag of+      Nothing -> execFailure aid req ApplyOutOfReach+      Just kit -> do+        itemFull <- getsState $ itemToFull iid+        actorSk <- currentSkillsServer aid+        localTime <- getsState $ getLocalTime (blid b)+        let skill = Ability.getSk Ability.SkApply actorSk+            legal = permittedApply corule localTime skill calmE (Just cstore)+                                   itemFull kit+        case legal of+          Left reqFail -> execFailure aid req reqFail+          Right _ -> applyItem aid iid cstore++-- * ReqGameRestart++reqGameRestart :: MonadServerAtomic m+               => ActorId -> GroupName ModeKind -> Challenge+               -> m ()+reqGameRestart aid groupName scurChalSer = do+  noConfirmsGame <- isNoConfirmsGame+  factionD <- getsState sfactionD+  let fidsUI = map fst $ filter (\(_, fact) -> fhasUI (gkind fact))+                                (EM.assocs factionD)+  -- This call to `revealItems` and `revealPerception` is really needed,+  -- because the other happens only at natural game conclusion,+  -- not at forced quitting.+  unless noConfirmsGame $+    mapM_ revealAll fidsUI+  -- Announcing end of game, we send lore, because game is over.+  b <- getsState $ getActorBody aid+  oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD+  factionAn <- getsServer sfactionAn+  generationAn <- getsServer sgenerationAn+  execUpdAtomic $ UpdQuitFaction+                    (bfid b)+                    oldSt+                    (Just $ Status Restart (fromEnum $ blid b) (Just groupName))+                    (Just (factionAn, generationAn))+  -- We don't save game and don't wait for clips end. ASAP.+  modifyServer $ \ser -> ser { sbreakASAP = True+                             , soptionsNxt = (soptionsNxt ser) {scurChalSer} }++-- * ReqGameDropAndExit++-- After we break out of the game loop, we will notice from @Camping@+-- we shouldn exit the game.+reqGameDropAndExit :: MonadServerAtomic m => ActorId -> m ()+reqGameDropAndExit aid = do+  verifyAssertExplored+  b <- getsState $ getActorBody aid+  oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD+  execUpdAtomic $ UpdQuitFaction+                    (bfid b)+                    oldSt+                    (Just $ Status Camping (fromEnum $ blid b) Nothing)+                    Nothing+  modifyServer $ \ser -> ser { sbreakASAP = True+                             , sbreakLoop = True }++verifyAssertExplored :: MonadServer m => m ()+verifyAssertExplored = do+  assertExplored <- getsServer $ sassertExplored . soptions+  case assertExplored of+    Nothing -> return ()+    Just lvlN -> do+      -- Exploration (by any party) verfied via spawning; beware of levels+      -- with disabled spawning.+      snumSpawned <- getsServer snumSpawned+      let !_A = assert (toEnum lvlN `EM.member` snumSpawned+                        || toEnum (- lvlN) `EM.member` snumSpawned+                        `blame` "by game end, exploration haven't reached the expected level depth, indicating stuck AI (or just very busy initial levels)"+                        `swith` lvlN) ()+      return ()++-- * ReqGameSaveAndExit++-- After we break out of the game loop, we will notice from @Camping@+-- we shouldn exit the game.+reqGameSaveAndExit :: MonadServerAtomic m => ActorId -> m ()+reqGameSaveAndExit aid = do+  verifyAssertExplored+  b <- getsState $ getActorBody aid+  oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD+  execUpdAtomic $ UpdQuitFaction+                    (bfid b)+                    oldSt+                    (Just $ Status Camping (fromEnum $ blid b) Nothing)+                    Nothing+  modifyServer $ \ser -> ser { sbreakASAP = True+                             , swriteSave = True }++-- * ReqGameSave++-- After we break out of the game loop, we will notice we shouldn't quit+-- the game and we will enter the game loop again.+reqGameSave :: MonadServer m => m ()+reqGameSave =+  modifyServer $ \ser -> ser { sbreakASAP = True+                             , swriteSave = True }++-- * ReqDoctrine++reqDoctrine :: MonadServerAtomic m => FactionId -> Ability.Doctrine -> m ()+reqDoctrine fid toT = do+  fromT <- getsState $ gdoctrine . (EM.! fid) . sfactionD+  execUpdAtomic $ UpdDoctrineFaction fid toT fromT++-- * ReqAutomate++reqAutomate :: MonadServerAtomic m => FactionId -> m ()+reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True
+ engine-src/Game/LambdaHack/Server/ItemM.hs view
@@ -0,0 +1,309 @@+-- | Server operations for items.+module Game.LambdaHack.Server.ItemM+  ( registerItem, moveStashIfNeeded, randomResetTimeout, embedItemOnPos+  , prepareItemKind, rollItemAspect, rollAndRegisterItem+  , placeItemsInDungeon, embedItemsInDungeon, mapActorCStore_+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , onlyRegisterItem, computeRndTimeout, createCaveItem, createEmbedItem+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.HashMap.Strict as HM++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.CaveKind (citemFreq, citemNum)+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.ItemRev+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++onlyRegisterItem :: MonadServerAtomic m => ItemKnown -> m ItemId+onlyRegisterItem itemKnown@(ItemKnown _ arItem _) = do+  itemRev <- getsServer sitemRev+  case HM.lookup itemKnown itemRev of+    Just iid -> return iid+    Nothing -> do+      icounter <- getsServer sicounter+      executedOnServer <-+        execUpdAtomicSer $ UpdDiscoverServer icounter arItem+      let !_A = assert executedOnServer ()+      modifyServer $ \ser ->+        ser { sitemRev = HM.insert itemKnown icounter (sitemRev ser)+            , sicounter = succ icounter }+      return $! icounter++registerItem :: MonadServerAtomic m+             => Bool -> ItemFullKit -> ItemKnown -> Container -> m ItemId+registerItem verbose (itemFull@ItemFull{itemBase, itemKindId, itemKind}, kit)+             itemKnown@(ItemKnown _ arItem _) containerRaw = do+  container <- case containerRaw of+    CActor aid CEqp -> do+      b <- getsState $ getActorBody aid+      return $! if eqpFreeN b >= fst kit+                then containerRaw+                else CActor aid CStash+    _ -> return containerRaw+  iid <- onlyRegisterItem itemKnown+  let slore = IA.loreFromContainer arItem container+  modifyServer $ \ser ->+    ser {sgenerationAn = EM.adjust (EM.insertWith (+) iid (fst kit)) slore+                                   (sgenerationAn ser)}+  moveStash <- moveStashIfNeeded container+  mapM_ execUpdAtomic moveStash+  execUpdAtomic $ UpdCreateItem verbose iid itemBase kit container+  let worth = itemPrice (fst kit) itemKind+  case container of+    _ | worth == 0 -> return ()+    CActor _ COrgan -> return ()  -- destroyed on drop+    CTrunk{} -> return ()  -- we assume any valuables in CEmbed can be dug out+    _ -> execUpdAtomic $ UpdAlterGold worth+  knowItems <- getsServer $ sknowItems . soptions+  when knowItems $ case container of+    CTrunk{} -> return ()+    _ -> execUpdAtomic $ UpdDiscover container iid itemKindId arItem+  -- The first recharging period after creation is random,+  -- between 1 and 2 standard timeouts of the item.+  -- In this way we avoid many rattlesnakes rattling in unison.+  case container of+    CActor _ cstore | cstore `elem` [CEqp, COrgan] ->+      randomResetTimeout (fst kit) iid itemFull [] container+    _ -> return ()+  return iid++moveStashIfNeeded :: MonadStateRead m => Container -> m [UpdAtomic]+moveStashIfNeeded c = case c of+  CActor aid CStash -> do+    b <- getsState $ getActorBody aid+    mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b+    case mstash of+      Just (lid, pos) -> do+        bagStash <- getsState $ getFloorBag lid pos+        return $! if EM.null bagStash+                  then [ UpdLoseStashFaction False (bfid b) lid pos+                       , UpdSpotStashFaction True (bfid b) (blid b) (bpos b) ]+                  else []+      Nothing -> return [UpdSpotStashFaction True (bfid b) (blid b) (bpos b)]+  _ -> return []++randomResetTimeout :: MonadServerAtomic m+                   => Int -> ItemId -> ItemFull -> [ItemTimer] -> Container+                   -> m ()+randomResetTimeout k iid itemFull beforeIt toC = do+  lid <- getsState $ lidFromC toC+  localTime <- getsState $ getLocalTime lid+  mrndTimeout <- rndToAction $ computeRndTimeout localTime itemFull+  -- The created or moved item set (not the items previously at destination)+  -- has its timeouts reset to a random value between timeout and twice timeout.+  -- This prevents micromanagement via swapping items in and out of eqp+  -- and via exact prediction of first timeout after equip.+  case mrndTimeout of+    Just rndT -> do+      bagAfter <- getsState $ getContainerBag toC+      let afterIt = case iid `EM.lookup` bagAfter of+            Nothing -> error $ "" `showFailure` (iid, bagAfter, toC)+            Just (_, it2) -> it2+          resetIt = beforeIt ++ replicate k rndT+      when (afterIt /= resetIt) $+        execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt+    Nothing -> return ()  -- no @Timeout@ aspect; don't touch++computeRndTimeout :: Time -> ItemFull -> Rnd (Maybe ItemTimer)+computeRndTimeout localTime ItemFull{itemDisco=ItemDiscoFull itemAspect} = do+  let t = IA.aTimeout itemAspect+  if t > 0 then do+    rndT <- randomR0 t+    let rndTurns = timeDeltaScale (Delta timeTurn) (t + rndT)+    return $ Just $ createItemTimer localTime rndTurns+  else return Nothing+computeRndTimeout _ _ = error "computeRndTimeout: server ignorant about an item"++createCaveItem :: MonadServerAtomic m => Point -> LevelId -> m ()+createCaveItem pos lid = do+  COps{cocave} <- getsState scops+  Level{lkind, ldepth} <- getLevel lid+  let container = CFloor lid pos+      litemFreq = citemFreq $ okind cocave lkind+  -- Power depth of new items unaffected by number of spawned actors.+  freq <- prepareItemKind 0 ldepth litemFreq+  mIidEtc <- rollAndRegisterItem True ldepth freq container Nothing+  createKitItems lid pos mIidEtc++createEmbedItem :: MonadServerAtomic m+                => LevelId -> Point -> GroupName ItemKind -> m ()+createEmbedItem lid pos grp = do+  Level{ldepth} <- getLevel lid+  let container = CEmbed lid pos+  -- Power depth of new items unaffected by number of spawned actors.+  freq <- prepareItemKind 0 ldepth [(grp, 1)]+  mIidEtc <- rollAndRegisterItem True ldepth freq container Nothing+  createKitItems lid pos mIidEtc++-- Create, register and insert all initial kit items.+createKitItems :: MonadServerAtomic m+               => LevelId -> Point -> Maybe (ItemId, ItemFullKit) -> m ()+createKitItems lid pos mIidEtc = case mIidEtc of+  Nothing -> error $ "" `showFailure` (lid, pos, mIidEtc)+  Just (_, (itemFull, _)) -> do+    cops <- getsState scops+    lvl@Level{ldepth} <- getLevel lid+    let ikit = IK.ikit $ itemKind itemFull+        nearbyPassable = take (20 + length ikit)+                         $ nearbyPassablePoints cops lvl pos+        walkable p = Tile.isWalkable (coTileSpeedup cops) (lvl `at` p)+        good p = walkable p && p `EM.notMember` lfloor lvl+        kitPos = zip ikit $ filter good nearbyPassable+                            ++ filter walkable nearbyPassable+                            ++ repeat pos+    forM_ kitPos $ \((ikGrp, cstore), p) -> do+      let container = if cstore == CGround+                      then CFloor lid p+                      else CEmbed lid pos+          itemFreq = [(ikGrp, 1)]+      -- Power depth of new items unaffected by number of spawned actors.+      freq <- prepareItemKind 0 ldepth itemFreq+      mresult <- rollAndRegisterItem False ldepth freq container Nothing+      assert (isJust mresult) $ return ()++-- Tiles already placed, so it's possible to scatter companion items+-- over walkable tiles.+embedItemOnPos :: MonadServerAtomic m+               => LevelId -> Point -> ContentId TileKind -> m ()+embedItemOnPos lid pos tk = do+  COps{cotile} <- getsState scops+  let embedGroups = Tile.embeddedItems cotile tk+  mapM_ (createEmbedItem lid pos) embedGroups++prepareItemKind :: MonadServerAtomic m+                => Int -> Dice.AbsDepth -> Freqs ItemKind+                -> m (Frequency+                        (GroupName ItemKind, ContentId IK.ItemKind, ItemKind))+prepareItemKind lvlSpawned ldepth itemFreq = do+  cops <- getsState scops+  uniqueSet <- getsServer suniqueSet+  totalDepth <- getsState stotalDepth+  return $! newItemKind cops uniqueSet itemFreq ldepth totalDepth lvlSpawned++rollItemAspect :: MonadServerAtomic m+               => Frequency+                    (GroupName ItemKind, ContentId IK.ItemKind, ItemKind)+               -> Dice.AbsDepth+               -> m NewItem+rollItemAspect freq ldepth = do+  cops <- getsState scops+  flavour <- getsServer sflavour+  discoRev <- getsServer sdiscoKindRev+  totalDepth <- getsState stotalDepth+  m2 <- rndToAction $ newItem cops freq flavour discoRev ldepth totalDepth+  case m2 of+    NewItem _ (ItemKnown _ arItem _) ItemFull{itemKindId} _ -> do+      when (IA.checkFlag Ability.Unique arItem) $+        modifyServer $ \ser ->+          ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)}+    NoNewItem -> return ()+  return m2++rollAndRegisterItem :: MonadServerAtomic m+                    => Bool+                    -> Dice.AbsDepth+                    -> Frequency+                         (GroupName ItemKind, ContentId IK.ItemKind, ItemKind)+                    -> Container+                    -> Maybe Int+                    -> m (Maybe (ItemId, ItemFullKit))+rollAndRegisterItem verbose ldepth freq container mk = do+  m2 <- rollItemAspect freq ldepth+  case m2 of+    NoNewItem -> return Nothing+    NewItem _ itemKnown itemFull kit -> do+      let f k = if k == 1 && null (snd kit)+                then quantSingle+                else (k, snd kit)+          !kit2 = maybe kit f mk+      iid <- registerItem verbose (itemFull, kit2) itemKnown container+      return $ Just (iid, (itemFull, kit2))++-- Tiles already placed, so it's possible to scatter over walkable tiles.+placeItemsInDungeon :: forall m. MonadServerAtomic m+                    => EM.EnumMap LevelId (EM.EnumMap FactionId Point) -> m ()+placeItemsInDungeon factionPositions = do+  COps{cocave, coTileSpeedup} <- getsState scops+  totalDepth <- getsState stotalDepth+  let initialItems (lid, lvl@Level{lkind, ldepth}) = do+        litemNum <- rndToAction $ castDice ldepth totalDepth+                                  (citemNum $ okind cocave lkind)+        let alPos = EM.elems $ EM.findWithDefault EM.empty lid factionPositions+            placeItems :: Int -> m ()+            placeItems n | n == litemNum = return ()+            placeItems !n = do+              Level{lfloor} <- getLevel lid+              -- Don't generate items around initial actors or in bunches.+              let distAndNotFloor !p _ =+                    let f !k = chessDist p k > 4+                    in p `EM.notMember` lfloor && all f alPos+              mpos <- rndToAction $ findPosTry2 10 lvl+                (\_ !t -> Tile.isWalkable coTileSpeedup t+                          && not (Tile.isNoItem coTileSpeedup t))+                [ \_ !t -> Tile.isVeryOftenItem coTileSpeedup t+                , \_ !t -> Tile.isCommonItem coTileSpeedup t ]+                distAndNotFloor+                (replicate 10 distAndNotFloor)+              case mpos of+                Just pos -> do+                  createCaveItem pos lid+                  placeItems (n + 1)+                Nothing -> debugPossiblyPrint+                  "Server: placeItemsInDungeon: failed to find positions"+        placeItems 0+  dungeon <- getsState sdungeon+  -- Make sure items on easy levels are generated first, to avoid all+  -- artifacts on deep levels.+  let fromEasyToHard = sortBy (comparing (ldepth . snd)) $ EM.assocs dungeon+  mapM_ initialItems fromEasyToHard++-- Tiles already placed, so it's possible to scatter companion items+-- over walkable tiles.+embedItemsInDungeon :: MonadServerAtomic m => m ()+embedItemsInDungeon = do+  let embedItemsOnLevel (lid, Level{ltile}) =+        PointArray.imapMA_ (embedItemOnPos lid) ltile+  dungeon <- getsState sdungeon+  -- Make sure items on easy levels are generated first, to avoid all+  -- artifacts on deep levels.+  let fromEasyToHard = sortBy (comparing (ldepth . snd)) $ EM.assocs dungeon+  mapM_ embedItemsOnLevel fromEasyToHard++-- | Mapping over actor's items from a give store.+mapActorCStore_ :: MonadServer m+                => CStore -> (ItemId -> ItemQuant -> m ()) -> Actor -> m ()+mapActorCStore_ cstore f b = do+  bag <- getsState $ getBodyStoreBag b cstore+  mapM_ (uncurry f) $ EM.assocs bag
+ engine-src/Game/LambdaHack/Server/ItemRev.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Creation of items on the server. Types and operations that don't involve+-- server state nor our custom monads.+module Game.LambdaHack.Server.ItemRev+  ( ItemKnown(..), NewItem(..), ItemRev, UniqueSet+  , newItemKind, newItem+    -- * Item discovery types+  , DiscoveryKindRev, emptyDiscoveryKindRev, serverDiscos+    -- * The @FlavourMap@ type+  , FlavourMap, emptyFlavourMap, dungeonFlavourMap+    -- * Important implementation parts, exposed for tests+  , rollFlavourMap+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , buildItem, keepMetaGameInformation+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.HashMap.Strict as HM+import           Data.Hashable (Hashable)+import           Data.Vector.Binary ()+import qualified Data.Vector.Unboxed as U+import           GHC.Generics (Generic)++import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.Flavour++-- | The essential item properties, used for the @ItemRev@ hash table+-- from items to their ids, needed to assign ids to newly generated items.+-- All the other meaningful properties can be derived from them.+-- Note: item seed instead of @AspectRecord@ is not enough,+-- becaused different seeds may result in the same @AspectRecord@+-- and we don't want such items to be distinct in UI and elsewhere.+data ItemKnown = ItemKnown ItemIdentity IA.AspectRecord (Maybe FactionId)+  deriving (Show, Eq, Generic)++instance Binary ItemKnown++instance Hashable ItemKnown++data NewItem =+    NewItem  (GroupName ItemKind) ItemKnown ItemFull ItemQuant+  | NoNewItem++-- | Reverse item map, for item creation, to keep items and item identifiers+-- in bijection.+type ItemRev = HM.HashMap ItemKnown ItemId++type UniqueSet = ES.EnumSet (ContentId ItemKind)++-- | Build an item with the given kind and aspects.+buildItem :: COps -> IA.AspectRecord -> FlavourMap+          -> DiscoveryKindRev -> ContentId ItemKind+          -> Item+buildItem COps{coitem} arItem (FlavourMap flavourMap)+          (DiscoveryKindRev discoRev) ikChosen =+  let jkind = case IA.aPresentAs arItem of+        Just grp ->+          let kindHidden = ouniqGroup coitem grp+          in IdentityCovered+               (toItemKindIx $ discoRev U.! contentIdIndex ikChosen)+               kindHidden+        Nothing -> IdentityObvious ikChosen+      jfid     = Nothing  -- the default+      jflavour = toEnum $ fromEnum $ flavourMap U.! contentIdIndex ikChosen+  in Item{..}++-- | Roll an item kind based on given @Freqs@ and kind rarities+newItemKind :: COps -> UniqueSet -> Freqs ItemKind+            -> Dice.AbsDepth -> Dice.AbsDepth -> Int+            -> Frequency (GroupName ItemKind, ContentId IK.ItemKind, ItemKind)+newItemKind COps{coitem, coItemSpeedup} uniqueSet itemFreq+            (Dice.AbsDepth ldepth) (Dice.AbsDepth totalDepth) lvlSpawned =+  assert (any (\(_, n) -> n > 0) itemFreq) $+  -- Effective generation depth of actors (not items) increases with spawns.+  -- Up to 10 spawns, no effect. With 20 spawns, depth + 5, and then+  -- each 10 spawns adds 5 depth.+  let numSpawnedCoeff = max 0 $ lvlSpawned `div` 2 - 5+      ldSpawned = ldepth + numSpawnedCoeff+      f _ _ acc _ ik _ | ik `ES.member` uniqueSet = acc+      f !itemGroup !q !acc !p !ik !kind =+        -- Don't consider lvlSpawned for uniques, except those that have+        -- @Unique@ under @Odds@.+        let ld = if IA.checkFlag Ability.Unique+                    $ IA.kmMean $ getKindMean ik coItemSpeedup+                 then ldepth+                 else ldSpawned+            rarity = linearInterpolation ld totalDepth (IK.irarity kind)+            !fr = q * p * rarity+        in (fr, (itemGroup, ik, kind)) : acc+      g (!itemGroup, !q) = ofoldlGroup' coitem itemGroup (f itemGroup q) []+      freqDepth = concatMap g itemFreq+  in toFreq "newItemKind" freqDepth++-- | Given item kind frequency, roll item kind, generate item aspects+-- based on level and put together the full item data set.+newItem :: COps+        -> Frequency (GroupName ItemKind, ContentId IK.ItemKind, ItemKind)+        -> FlavourMap -> DiscoveryKindRev+        -> Dice.AbsDepth -> Dice.AbsDepth+        -> Rnd NewItem+newItem cops freq flavourMap discoRev levelDepth totalDepth =+  if nullFreq freq+  then return NoNewItem  -- e.g., rare tile has a unique embed, only first time+  else do+    (itemGroup, itemKindId, itemKind) <- frequency freq+    -- Number of new items/actors unaffected by number of spawned actors.+    itemN <- castDice levelDepth totalDepth (IK.icount itemKind)+    arItem <- IA.rollAspectRecord (IK.iaspects itemKind) levelDepth totalDepth+    let itemBase = buildItem cops arItem flavourMap discoRev itemKindId+        itemIdentity = jkind itemBase+        !itemK = max 1 itemN+        !itemTimer = [itemTimerZero | IA.checkFlag Ability.Periodic arItem]+          -- enable optimization in @applyPeriodicLevel@+        itemSuspect = False+        -- Bonuses on items/actors unaffected by number of spawned actors.+        itemDisco = ItemDiscoFull arItem+        itemFull = ItemFull {..}+        itemKnown = ItemKnown itemIdentity arItem (jfid itemBase)+        itemQuant = if itemK == 1 && null itemTimer+                    then quantSingle+                    else (itemK, itemTimer)+    return $! NewItem itemGroup itemKnown itemFull itemQuant++-- | The reverse map to @DiscoveryKind@, needed for item creation.+-- This is total and never changes, hence implemented as vector.+-- Morally, it's indexed by @ContentId ItemKind@ and elements are @ItemKindIx@.+newtype DiscoveryKindRev = DiscoveryKindRev (U.Vector Word16)+  deriving (Show, Binary)++emptyDiscoveryKindRev :: DiscoveryKindRev+emptyDiscoveryKindRev = DiscoveryKindRev U.empty++serverDiscos :: COps -> DiscoveryKindRev+             -> Rnd (DiscoveryKind, DiscoveryKindRev)+serverDiscos COps{coitem} (DiscoveryKindRev discoRevFromPreviousGame) = do+  let ixs = [0..toEnum (olength coitem - 1)]+  shuffled <-+    if U.null discoRevFromPreviousGame+    then shuffle ixs+    else shuffleExcept (keepMetaGameInformation coitem discoRevFromPreviousGame)+                       (olength coitem)+                       ixs+  let udiscoRev = U.fromListN (olength coitem) shuffled+      f :: ContentId ItemKind -> Word16 -> (ItemKindIx, ContentId ItemKind)+      f ik ikx = (toItemKindIx ikx, ik)+      -- Not @fromDistinctAscList@, because it's the reverse map.+      discoS = EM.fromList $ zipWith f [toEnum 0 ..] $ U.toList udiscoRev+  return (discoS, DiscoveryKindRev udiscoRev)++-- | Keep in a vector the information that is retained from playthrough+-- to playthrough. The information being, e.g., @ItemKindIx@ or @Flavour@.+-- The information is morally indexed by @ContentId ItemKind@ and its @Enum@+-- instance fits in @Word16@.+keepMetaGameInformation :: ContentData ItemKind+                        -> U.Vector Word16+                        -> U.Vector Word16+keepMetaGameInformation coitem informationFromPreviousGame =+  let inMetaGame :: ContentId ItemKind -> Bool+      inMetaGame kindId =+        IK.SetFlag Ability.MetaGame `elem` IK.iaspects (okind coitem kindId)+      keepMeta :: Int -> Word16 -> Word16+      keepMeta i ix = if inMetaGame (toEnum i)+                      then ix+                      else invalidInformationCode+  in U.imap keepMeta informationFromPreviousGame++-- | Flavours assigned by the server to item kinds, in this particular game.+-- This is total and never changes, hence implemented as vector.+-- Morally, it's indexed by @ContentId ItemKind@ and elements are @Flavour@.+newtype FlavourMap = FlavourMap (U.Vector Word16)+  deriving (Show, Binary)++emptyFlavourMap :: FlavourMap+emptyFlavourMap = FlavourMap U.empty++-- | Assigns flavours to item kinds. Assures no flavor is repeated for the same+-- symbol, except for items with only one permitted flavour.+rollFlavourMap+  :: U.Vector Word16+  -> Rnd ( EM.EnumMap (ContentId ItemKind) Flavour+         , EM.EnumMap (ContentSymbol ItemKind) (ES.EnumSet Flavour) )+  -> ContentId ItemKind -> ItemKind+  -> Rnd ( EM.EnumMap (ContentId ItemKind) Flavour+         , EM.EnumMap (ContentSymbol ItemKind) (ES.EnumSet Flavour) )+rollFlavourMap uFlavMeta !rnd !key !ik = case IK.iflavour ik of+  [] -> error "empty iflavour"+  [flavour] -> do+    (!assocs, !availableMap) <- rnd+    return ( EM.insert key flavour assocs+           , availableMap )+  flvs -> do+    (!assocs, !availableMap) <- rnd+    let a0 = uFlavMeta U.! toEnum (fromEnum key)+    if a0 == invalidInformationCode then do+      if length flvs < 6 then do  -- too few to even attempt unique assignment+        flavour <- oneOf flvs+        return ( EM.insert key flavour assocs+               , availableMap )+      else do+        let available = availableMap EM.! IK.isymbol ik+            proper = ES.fromList flvs `ES.intersection` available+        assert (not (ES.null proper)+                `blame` "not enough flavours for items"+                `swith` (flvs, available, ik, availableMap)) $ do+          flavour <- oneOf $ ES.elems proper+          let availableReduced = ES.delete flavour available+          return ( EM.insert key flavour assocs+                 , EM.insert (IK.isymbol ik) availableReduced availableMap )+    else return ( EM.insert key (toEnum $ fromEnum a0) assocs+                , availableMap )++-- | Randomly chooses flavour for all item kinds for this game.+dungeonFlavourMap :: COps -> FlavourMap -> Rnd FlavourMap+dungeonFlavourMap COps{coitem} (FlavourMap flavourMapFromPreviousGame) = do+  let uFlavMeta = if U.null flavourMapFromPreviousGame+                  then U.replicate (olength coitem) invalidInformationCode+                  else keepMetaGameInformation coitem flavourMapFromPreviousGame+      flavToAvailable :: EM.EnumMap Char (ES.EnumSet Flavour) -> Int -> Word16+                      -> EM.EnumMap Char (ES.EnumSet Flavour)+      flavToAvailable em i fl =+        let ik = okind coitem (toEnum i)+            setBase = EM.findWithDefault (ES.fromList stdFlavList)+                                         (IK.isymbol ik)+                                         em+            setMeta = if fl == invalidInformationCode+                      then setBase+                      else ES.delete (toEnum $ fromEnum fl) setBase+        in EM.insert (IK.isymbol ik) setMeta em+      availableMap = U.ifoldl' flavToAvailable EM.empty uFlavMeta+  (assocsFlav, _) <- ofoldlWithKey' coitem (rollFlavourMap uFlavMeta)+                                    (return (EM.empty, availableMap))+  let uFlav = U.fromListN (olength coitem)+              $ map (toEnum . fromEnum) $ EM.elems assocsFlav+  return $! FlavourMap uFlav
+ engine-src/Game/LambdaHack/Server/LoopM.hs view
@@ -0,0 +1,750 @@+-- | The main loop of the server, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Server.LoopM+  ( loopSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip+  , manageCalmAndDomination, applyPeriodicLevel+  , handleTrajectories, hTrajectories, advanceTrajectory+  , handleActors, hActors, handleUIunderAI, dieSer, restartGame+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client (ReqUI (..), Response (..))+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Analytics+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.ItemAspect as IA+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.FactionKind+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.RuleKind+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.CommonM+import           Game.LambdaHack.Server.HandleEffectM+import           Game.LambdaHack.Server.HandleRequestM+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.PeriodicM+import           Game.LambdaHack.Server.ProtocolM+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.StartM+import           Game.LambdaHack.Server.State++-- | Start a game session, including the clients, and then loop,+-- communicating with the clients.+--+-- The loop is started in server state that is empty, see 'emptyStateServer'.+loopSer :: (MonadServerAtomic m, MonadServerComm m)+        => ServerOptions+             -- ^ player-supplied server options+        -> (Bool -> FactionId -> ChanServer -> IO ())+             -- ^ function that initializes a client and runs its main loop+        -> m ()+loopSer serverOptions executorClient = do+  -- Recover states and launch clients.+  modifyServer $ \ser -> ser { soptionsNxt = serverOptions+                             , soptions = serverOptions }+  cops <- getsState scops+  let updConn startsNewGame = updateConn $ executorClient startsNewGame+  restored <- tryRestore+  case restored of+    Just (sRaw, ser) | not $ snewGameSer serverOptions -> do  -- a restored game+      execUpdAtomic $ UpdResumeServer+                    $ updateCOpsAndCachedData (const cops) sRaw+      putServer ser {soptionsNxt = serverOptions}+      applyDebug+      factionD <- getsState sfactionD+      let f fid = let cmd = UpdResumeServer+                            $ updateCOpsAndCachedData (const cops)+                            $ sclientStates ser EM.! fid+                  in execUpdAtomicFidCatch fid cmd+      mapM_ (void <$> f) $ EM.keys factionD+      updConn False+      initPer+      pers <- getsServer sperFid+      let clear = const emptyPer+          persFid fid | sknowEvents serverOptions = EM.map clear (pers EM.! fid)+                      | otherwise = pers EM.! fid+      mapM_ (\fid -> sendUpdate fid $ UpdResume fid (persFid fid))+            (EM.keys factionD)+      arenasNew <- arenasForLoop+      modifyServer $ \ser2 -> ser2 {sarenas = arenasNew, svalidArenas = True}+      -- We dump RNG seeds here, based on @soptionsNxt@, in case the game+      -- wasn't run with @--dumpInitRngs@ previously, but we need the seeds,+      -- e.g., to diagnose a crash.+      rngs <- getsServer srngs+      when (sdumpInitRngs serverOptions) $ dumpRngs rngs+    _ -> do  -- starting new game for this savefile (--newGame or fresh save)+      factionDold <- getsState sfactionD+      s <- gameReset serverOptions Nothing Nothing+             -- get RNG from item boost+      -- Set up commandline options.+      let optionsBarRngs =+            serverOptions {sdungeonRng = Nothing, smainRng = Nothing}+      modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs+                                 , soptions = optionsBarRngs }+      execUpdAtomic $ UpdRestartServer s+      updConn True+      initPer+      reinitGame factionDold+      writeSaveAll False False+  loopUpd $ updConn True++factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId)+factionArena fact = case gleader fact of+  -- Even spawners need an active arena for their leader,+  -- or they start clogging stairs.+  Just leader -> do+    b <- getsState $ getActorBody leader+    return $ Just $ blid b+  Nothing -> return Nothing+    -- This means Allure heroes can kill all aliens on lvl 4, retreat,+    -- hide and sleep on lvl 3 and they are guaranteed aliens don't spawn.+    -- However, animals still spawn, if slowly, and aliens resume+    -- spawning when heroes move on again.++arenasForLoop :: MonadStateRead m => m (ES.EnumSet LevelId)+{-# INLINE arenasForLoop #-}+arenasForLoop = do+  factionD <- getsState sfactionD+  marenas <- mapM factionArena $ EM.elems factionD+  let arenas = ES.fromList $ catMaybes marenas+      !_A = assert (not (ES.null arenas)+                    `blame` "game over not caught earlier"+                    `swith` factionD) ()+  return $! arenas++handleFidUpd :: forall m. (MonadServerAtomic m, MonadServerComm m)+             => (FactionId -> m ()) -> FactionId -> Faction -> m ()+{-# INLINE handleFidUpd #-}+handleFidUpd updatePerFid fid fact = do+  -- Update perception on all levels at once,+  -- in case a leader is changed to actor on another+  -- (possibly not even currently active) level.+  -- This runs for all factions even if save is requested by UI.+  -- Let players ponder new game state while the engine is busy saving.+  -- Also, this ensures perception before game save is exactly the same+  -- as at game resume, which is an invariant we check elsewhere.+  -- However, if perception is not updated after the action, the actor+  -- may not see his vicinity, so may not see enemy that displaces (or hits) him+  -- resulting in breaking the displace action and temporary leader loss,+  -- which is fine, though a bit alarming. So, we update it at the end.+  updatePerFid fid+  -- Move a single actor only. Note that the skipped actors are not marked+  -- as waiting. Normally they will act in the next clip or the next few,+  -- so that's natural. But if there are dozens of them, this is wierd.+  -- E.g., they don't move, but still make nearby foes lose Calm.+  -- However, for KISS, we leave it be.+  --+  -- Bail out if immediate loop break- requested by UI. No check+  -- for @sbreakLoop@ needed, for the same reasons as in @handleActors@.+  let handle :: [LevelId] -> m Bool+      handle [] = return False+      handle (lid : rest) = do+        breakASAP <- getsServer sbreakASAP+        if breakASAP+        then return False+        else do+          nonWaitMove <- handleActors lid fid+          if nonWaitMove+          then return True+          else handle rest+      killDying :: [LevelId] -> m ()+      killDying = mapM_ killDyingLid+      killDyingLid :: LevelId -> m ()+      killDyingLid lid = do+        localTime <- getsState $ getLocalTime lid+        levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime+        let l = filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime+            killAid (aid, _) = do+              b1 <- getsState $ getActorBody aid+              when (bhp b1 <= 0) $ dieSer aid b1+        mapM_ killAid l+  -- Start on arena with leader, if available. This is crucial to ensure+  -- that no actor (even ours) moves before UI declares save(&exit).+  fa <- factionArena fact+  arenas <- getsServer sarenas+  let myArenas = case fa of+        Just myArena -> myArena : delete myArena (ES.elems arenas)+        Nothing -> ES.elems arenas+  nonWaitMove <- handle myArenas+  breakASAP <- getsServer sbreakASAP+  unless breakASAP $ killDying myArenas+  -- We update perception at the end, see comment above. This is usually+  -- cheap, and when not, if it's AI faction, it's a waste, but if it's UI,+  -- that's exactly where it prevents lost attack messages, etc.+  -- If the move was a wait, perception unchanged, so no need to update,+  -- unless the actor starts sleeping, in which case his perception+  -- is reduced a bit later, so no harm done.+  when nonWaitMove $ updatePerFid fid++-- | Handle a clip (the smallest fraction of a game turn for which a frame may+-- potentially be generated). Run the leader and other actors moves.+-- Eventually advance the time and repeat.+loopUpd :: forall m. (MonadServerAtomic m, MonadServerComm m)+        => m () -> m ()+loopUpd updConn = do+  let updatePerFid :: FactionId -> m ()+      {-# NOINLINE updatePerFid #-}+      updatePerFid fid = do  -- {-# SCC updatePerFid #-} do+        perValid <- getsServer $ (EM.! fid) . sperValidFid+        mapM_ (\(lid, valid) -> unless valid $ updatePer fid lid)+              (EM.assocs perValid)+      handleFid :: (FactionId, Faction) -> m ()+      {-# NOINLINE handleFid #-}+      handleFid (fid, fact) = do+        breakASAP <- getsServer sbreakASAP+        -- Don't process other factions, even their perceptions,+        -- if UI saves and/or exits.+        unless breakASAP $ handleFidUpd updatePerFid fid fact+      loopConditionally = do+        factionD <- getsState sfactionD+        -- Update perception one last time to satisfy save/resume assertions,+        -- because we may get here at arbitrary moment due to game over+        -- and so have outdated perception.+        mapM_ updatePerFid (EM.keys factionD)+        modifyServer $ \ser -> ser { sbreakLoop = False+                                   , sbreakASAP = False }+        endOrLoop loopUpdConn (restartGame updConn loopUpdConn)+      loopUpdConn = do+        factionD <- getsState sfactionD+        -- Start handling actors with the single UI faction,+        -- to safely save/exit. Note that this hack fails if there are many UI+        -- factions (when we reenable multiplayer). Then players will request+        -- save&exit and others will vote on it and it will happen+        -- after the clip has ended, not at the start.+        -- Note that at most a single actor with a time-consuming action+        -- is processed per faction, so it's fair, but many loops are needed.+        let hasUI (_, fact) = fhasUI (gkind fact)+            (factionUI, factionsRest) = case break hasUI $ EM.assocs factionD of+              (noUI1, ui : noUI2) -> (ui, noUI1 ++ noUI2)+              _ -> error "no UI faction in the game"+        mapM_ handleFid $ factionUI : factionsRest+        breakASAP <- getsServer sbreakASAP+        breakLoop <- getsServer sbreakLoop+        if breakASAP || breakLoop+        then loopConditionally+        else do+          -- Projectiles are processed last and not at all if the UI leader+          -- decides to save or exit or restart or if there is game over.+          -- This and UI leader acting before any other ordinary actors+          -- ensures state is not changed and so the clip doesn't need+          -- to be carried through before save.+          arenas <- getsServer sarenas+          mapM_ (\fid -> mapM_ (`handleTrajectories` fid) $ ES.elems arenas)+                (EM.keys factionD)+          endClip updatePerFid  -- must be last, in case performs a bkp save+          -- The condition can be changed in @handleTrajectories@ by pushing+          -- onto an escape and in @endClip@.+          breakLoop2 <- getsServer sbreakLoop+          if breakLoop2+          then loopConditionally+          else loopUpdConn  -- process next iteration unconditionally+  loopUpdConn++-- | Handle the end of every clip. Do whatever has to be done+-- every fixed number of clips, e.g., monster generation.+-- Advance time. Perform periodic saves, if applicable.+--+-- This is never run if UI requested save or exit or restart and it's correct,+-- because we know nobody moved and no time was or needs to be advanced+-- and arenas are not changed. After game was saved and exited,+-- on game resume the first clip is performed with empty arenas,+-- so arena time is not updated and nobody moves, nor anything happens,+-- but arenas are here correctly updated.+endClip :: forall m. MonadServerAtomic m => (FactionId -> m ()) -> m ()+{-# INLINE endClip #-}+endClip updatePerFid = do+  COps{corule} <- getsState scops+  time <- getsState stime+  let clipN = time `timeFit` timeClip+  -- No check if @sbreakASAP@ is set, because then the function is not called.+  breakLoop <- getsServer sbreakLoop+  -- We don't send a lot of useless info to the client if the game has already+  -- ended. At best wasteful, at worst the player sees strange messages.+  unless breakLoop $ do+    -- I need to send time updates, because I can't add time to each command,+    -- because I'd need to send also all arenas, which should be updated,+    -- and this is too expensive data for each, e.g., projectile move.+    -- I send even if nothing changes so that UI time display can progress.+    -- Possibly @arenas@ are invalid here, but all moves were performed+    -- according to this value, so time should be replenished according+    -- to this value as well.+    -- This is crucial, because tiny time discrepancies can accumulate+    -- magnified by hunders of actors that share the clip slots due to the+    -- restriction that at most one faction member acts each clip.+    arenas <- getsServer sarenas+    execUpdAtomic $ UpdAgeGame arenas+    -- Perform periodic dungeon maintenance.+    when (clipN `mod` rleadLevelClips corule == 0) leadLevelSwitch+    case clipN `mod` clipsInTurn of+      0 ->+        -- Spawn monsters at most once per 3 turns.+        when (clipN `mod` (3 * clipsInTurn) == 0)+          spawnMonster+      4 ->+        -- Periodic activation only once per turn, for speed,+        -- but on all active arenas. Calm updates and domination+        -- happen there as well. Once per turn is too rare for accurate+        -- expiration of short conditions, e.g., 1-turn haste. TODO.+        applyPeriodicLevel+      _ -> return ()+  -- @applyPeriodicLevel@ might have, e.g., dominated actors, ending the game.+  -- It could not have unended the game, though.+  breakLoop2 <- getsServer sbreakLoop+  unless breakLoop2 $ do+    -- Possibly a leader change due to @leadLevelSwitch@, so update arenas here+    -- for 100% accuracy at least at the start of actor moves, before they+    -- change leaders as part of their moves.+    --+    -- After game resume, this is the first non-vacuus computation.+    -- Next call to @loopUpdConn@ really moves actors and updates arena times+    -- so we start in exactly the same place that UI save ended in.+    validArenas <- getsServer svalidArenas+    unless validArenas $ do+      arenasNew <- arenasForLoop+      modifyServer $ \ser -> ser {sarenas = arenasNew, svalidArenas = True}+  -- Update all perception for visual feedback and to make sure saving+  -- and resuming game doesn't affect gameplay (by updating perception).+  -- Perception updates in @handleFidUpd@ are not enough, because+  -- periodic actions could have invalidated them.+  factionD <- getsState sfactionD+  mapM_ updatePerFid (EM.keys factionD)+  -- Saving on the browser causes a huge lag, hence autosave disabled.+#ifndef USE_JSFILE+  unless breakLoop2 $  -- if by chance requested and periodic saves coincide+    -- Periodic save needs to be at the end, so that restore can start+    -- at the beginning. Double save on first turn is avoided with @succ@.+    when (succ clipN `mod` rwriteSaveClips corule == 0) $+      writeSaveAll False False+#endif++-- | Check if the given actor is dominated and update his calm.+manageCalmAndDomination :: MonadServerAtomic m => ActorId -> Actor -> m ()+manageCalmAndDomination aid b = do+  performedDomination <-+    if bcalm b > 0 then return False else do  -- triggered by zeroed Calm+      hiImpression <- highestImpression b+      case hiImpression of+        Nothing -> return False+        Just (hiImpressionFid, hiImpressionK) -> do+          fact <- getsState $ (EM.! bfid b) . sfactionD+          if fhasPointman (gkind fact)+               -- animals/robots/human drones never Calm-dominated+             || hiImpressionK >= 10+               -- unless very high impression, e.g., in a dominated hero+          then dominateFidSfx aid aid (btrunk b) hiImpressionFid+          else return False+  unless performedDomination $ do+    newCalmDelta <- getsState $ regenCalmDelta aid b+    unless (newCalmDelta == 0) $+      -- Update delta for the current player turn.+      updateCalm aid newCalmDelta++-- | Trigger periodic items for all actors on the given level.+applyPeriodicLevel :: MonadServerAtomic m => m ()+applyPeriodicLevel = do+  arenas <- getsServer sarenas+  let applyPeriodicItem _ _ (_, (_, [])) = return ()+        -- periodic items always have at least one timer+      applyPeriodicItem aid cstore (iid, _) = do+        itemFull <- getsState $ itemToFull iid+        let arItem = aspectRecordFull itemFull+        when (IA.checkFlag Ability.Periodic arItem) $ do+          -- Check if the item is still in the bag (previous items act!).+          b2 <- getsState $ getActorBody aid+          bag <- getsState $ getBodyStoreBag b2 cstore+          case iid `EM.lookup` bag of+            Nothing -> return ()  -- item dropped+            Just (k, _) -> do+              -- Activate even if effects null or vacuous, to possibly+              -- destroy the item.+              let effApplyFlags = EffApplyFlags+                    { effToUse            = EffBare  -- no periodic crafting+                    , effVoluntary        = True+                    , effUseAllCopies     = k <= 1+                    , effKineticPerformed = False+                    , effActivation       = Ability.ActivationPeriodic+                    , effMayDestroy       = True+                    }+              void $ effectAndDestroyAndAddKill+                       effApplyFlags+                       aid aid aid iid (CActor aid cstore) itemFull+      applyPeriodicActor (aid, b) =+        -- While it's fun when projectiles flash or speed up mid-air,+        -- it's very exotic and quite time-intensive whenever hundreds+        -- of projectiles exist due to ongoing explosions.+        -- Nothing activates when actor dying to prevent a regenerating+        -- actor from resurrecting each turn, resulting in silly gameover stats.+        when (not (bproj b) && bhp b > 0 && blid b `ES.member` arenas) $ do+          -- Equipment goes first, to refresh organs before they expire,+          -- to avoid the message that organ expired.+          mapM_ (applyPeriodicItem aid CEqp) $ EM.assocs $ beqp b+          mapM_ (applyPeriodicItem aid COrgan) $ EM.assocs $ borgan b+          -- While we are at it, also update his Calm.+          manageCalmAndDomination aid b+  allActors <- getsState sactorD+  mapM_ applyPeriodicActor $ EM.assocs allActors++handleTrajectories :: MonadServerAtomic m => LevelId -> FactionId -> m ()+handleTrajectories lid fid = do+  localTime <- getsState $ getLocalTime lid+  levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . strajTime+  let l = sort $ map fst+          $ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime+  -- The @strajTime@ map may be outdated before @hTrajectories@+  -- call (due to other actors following their trajectories),+  -- so it's only used to decide which actors are processed in this+  -- @handleTrajectories@ call. If an actor is added to the map,+  -- the recursive call to @handleTrajectories@ will detect that+  -- and process him later on.+  -- If the actor is no longer on the level or no longer belongs+  -- to the faction, it is nevertheless processed without a problem.+  -- We are guaranteed the actor still exists.+  mapM_ hTrajectories l+  -- Avoid frames between fadeout and fadein.+  breakLoop <- getsServer sbreakLoop+  unless (null l || breakLoop) $+    handleTrajectories lid fid  -- for speeds > tile/clip++hTrajectories :: MonadServerAtomic m => ActorId -> m ()+{-# INLINE hTrajectories #-}+hTrajectories aid = do+  b1 <- getsState $ getActorBody aid+  let removePushed b =+        -- No longer fulfills criteria and was not removed by dying; remove him.+        modifyServer $ \ser ->+          ser { strajTime =+                  EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)+                            (strajTime ser)+              , strajPushedBy = EM.delete aid (strajPushedBy ser) }+      removeTrajectory b =+        -- Non-projectile actor stops flying (a projectile with empty trajectory+        -- would be intercepted earlier on as dead).+        -- Will be removed from @strajTime@ in recursive call+        -- to @handleTrajectories@.+        assert (not $ bproj b)+        $ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing+  breakLoop <- getsServer sbreakLoop+  if breakLoop then return ()  -- don't move if game over via pushing+  else if actorDying b1 then dieSer aid b1+  else case btrajectory b1 of+    Nothing -> removePushed b1+    Just ([], _) -> removeTrajectory b1 >> removePushed b1+    Just{} -> do+      advanceTrajectory aid b1+      -- Here, @advanceTrajectory@ might have affected @actorDying@,+      -- so we check again ASAP to make sure the body of the projectile+      -- (or pushed actor) doesn't block movement of other actors,+      -- but vanishes promptly.+      -- Bodies of actors that die not flying remain on the battlefied until+      -- their natural next turn, to give them a chance of rescue.+      -- Note that domination of pushed actors is not checked+      -- nor is their calm updated. They are helpless wrt movement,+      -- but also invulnerable in this respect.+      b2 <- getsState $ getActorBody aid+      if actorDying b2+      then dieSer aid b2+      else case btrajectory b2 of+        Nothing -> removePushed b2+        Just ([], _) -> removeTrajectory b2 >> removePushed b2+        Just{} -> -- delay next iteration only if still flying+          advanceTimeTraj aid+  -- if @actorDying@ due to @bhp b <= 0@:+  -- If @b@ is a projectile, it means hits an actor or is hit by actor.+  -- Then the carried item is destroyed and that's all.+  -- If @b@ is not projectile, it dies, his items drop to the ground+  -- and possibly a new leader is elected.+  --+  -- if @actorDying@ due to @btrajectory@ null:+  -- A projectile drops to the ground due to obstacles or range.+  -- The carried item is not destroyed, unless it's fragile,+  -- but drops to the ground.++-- | Manage trajectory of a projectile or a pushed other actor.+--+-- Colliding with a wall or actor doesn't take time, because+-- the projectile does not move (the move is blocked).+-- Not advancing time forces dead projectiles to be destroyed ASAP.+-- Otherwise, with some timings, it can stay on the game map dead,+-- blocking path of human-controlled actors and alarming the hapless human.+advanceTrajectory :: MonadServerAtomic m => ActorId -> Actor -> m ()+advanceTrajectory aid b1 = do+  COps{coTileSpeedup} <- getsState scops+  lvl <- getLevel $ blid b1+  arTrunk <- getsState $ (EM.! btrunk b1) . sdiscoAspect+  let registerKill killHow =+        -- Kill counts for each blast particle is TMI.+        when (bproj b1+              && not (IA.checkFlag Ability.Blast arTrunk)) $ do+          killer <- getsServer $ EM.findWithDefault aid aid . strajPushedBy+          addKillToAnalytics killer killHow (bfid b1) (btrunk b1)+  case btrajectory b1 of+    Just (d : lv, speed) -> do+      let tpos = bpos b1 `shift` d  -- target position+      if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then do+           -- Hit will clear trajectories in @reqMelee@,+           -- so no need to do that here.+           execUpdAtomic $ UpdTrajectory aid (btrajectory b1) (Just (lv, speed))+           when (null lv) $ registerKill KillDropLaunch+           let occupied = occupiedBigLvl tpos lvl || occupiedProjLvl tpos lvl+               reqMoveHit = reqMoveGeneric False True aid d+               reqDisp = reqDisplaceGeneric False aid+           if | bproj b1 -> reqMoveHit  -- projectiles always hit+              | occupied ->+                -- Non-projectiles displace if they are ending their flight+                -- or if only a projectile is in the way.+                -- So, no chaos of displacing a whole line of enemies.+                case (posToBigLvl tpos lvl, posToProjsLvl tpos lvl) of+                  (Nothing, []) -> error "advanceTrajectory: not occupied"+                  (Nothing, [target]) -> reqDisp target+                  (Nothing, _) -> reqMoveHit  -- can't displace multiple+                  (Just target, []) ->+                    if null lv then reqDisp target else reqMoveHit+                  (Just _, _) -> reqMoveHit  -- can't displace multiple+              | otherwise -> reqMoveHit  -- if not occupied, just move+      else do+           -- Will be removed from @strajTime@ in recursive call+           -- to @handleTrajectories@.+           unless (bproj b1) $+             execSfxAtomic $ SfxCollideTile aid tpos+           embedsPre <- getsState $ getEmbedBag (blid b1) tpos+           -- No crafting by projectiles that bump tiles nor by pushed actors.+           -- The only way is if they land in a tile (are engulfed by it)+           -- and have enough skill. But projectiles transform when hitting,+           -- if terrain permits, not just bump off the obstacle.+           mfail <- reqAlterFail (not $ bproj b1) EffBare False aid tpos+           embedsPost <- getsState $ getEmbedBag (blid b1) tpos+           b2 <- getsState $ getActorBody aid+           let tpos2 = bpos b2 `shift` d  -- possibly another level and/or bpos+           lvl2 <- getLevel $ blid b2+           case mfail of+             Nothing | Tile.isWalkable coTileSpeedup $ lvl2 `at` tpos2 ->+               -- Too late to announce anything, but given that the way+               -- is opened, continue flight. Don't even normally lose any HP,+               -- because it's not a hard collision, but altering.+               -- However, if embed was possibly triggered/removed, lose HP.+               if embedsPre /= embedsPost && not (EM.null embedsPre) then+                 if bhp b2 > oneM then do+                   execUpdAtomic $ UpdRefillHP aid minusM+                   b3 <- getsState $ getActorBody aid+                   advanceTrajectory aid b3+                 else do+                   -- Projectile has too low HP to pierce; terminate its flight.+                   execUpdAtomic $ UpdTrajectory aid (btrajectory b2)+                                 $ Just ([], speed)+                   registerKill KillTileLaunch+               else+                 -- Try again with the cleared path and possibly actors+                 -- spawned in the way, etc.+                 advanceTrajectory aid b2+             _ -> do+               -- Altering failed to open the passage, probably just a wall,+               -- so lose HP due to being pushed into an obstacle.+               -- Never kill in this way.+               -- Note that sometimes this may come already after one faction+               -- wins the game and end game screens are show. This is OK-ish.+               -- @Nothing@ trajectory of signals an obstacle hit.+               -- If projectile, second call of @actorDying@ above+               -- will take care of dropping dead.+               execUpdAtomic $ UpdTrajectory aid (btrajectory b2) Nothing+               -- If projectile, losing HP due to hitting an obstacle+               -- not needed, because trajectory is halted, so projectile+               -- will die soon anyway+               if bproj b2+               then registerKill KillTileLaunch+               else when (bhp b2 > oneM) $ do+                 execUpdAtomic $ UpdRefillHP aid minusM+                 let effect = IK.RefillHP (-2)  -- -2 is a lie to ensure display+                 execSfxAtomic $ SfxEffect (bfid b2) aid (btrunk b2) effect (-1)+    _ -> error $ "Nothing or empty trajectory" `showFailure` (aid, b1)++handleActors :: (MonadServerAtomic m, MonadServerComm m)+             => LevelId -> FactionId -> m Bool+handleActors lid fid = do+  localTime <- getsState $ getLocalTime lid+  levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime+  let l = sort $ map fst+          $ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime+  -- The @sactorTime@ map may be outdated before @hActors@+  -- call (due to other actors on the list acting),+  -- so it's only used to decide which actors are processed in this call.+  -- If the actor is no longer on the level or no longer belongs+  -- to the faction, it is nevertheless processed without a problem+  -- (the client may act wrt slightly outdated Perception and that's all).+  -- We are guaranteed the actor still exists.+  mleader <- getsState $ gleader . (EM.! fid) . sfactionD+  -- Leader acts first, so that UI leader can save&exit before state changes.+  hActors $ case mleader of+    Just aid | aid `elem` l -> aid : delete aid l+    _ -> l++hActors :: forall m. (MonadServerAtomic m, MonadServerComm m)+        => [ActorId] -> m Bool+hActors [] = return False+hActors as@(aid : rest) = do+ b1 <- getsState $ getActorBody aid+ let !_A = assert (not $ bproj b1) ()+ if bhp b1 <= 0 then+   -- Will be killed in a later pass, making it possible to revive him now.+   hActors rest+ else do+  let side = bfid b1+  fact <- getsState $ (EM.! side) . sfactionD+  breakLoop <- getsServer sbreakLoop+  let mleader = gleader fact+      aidIsLeader = mleader == Just aid+      mainUIactor = fhasUI (gkind fact)+                    && (aidIsLeader || not (fhasPointman (gkind fact)))+      -- Checking @breakLoop@, to avoid doubly setting faction status to Camping+      -- in case AI-controlled UI client asks to exit game at exactly+      -- the same moment as natural game over was detected.+      mainUIunderAI = mainUIactor && gunderAI fact && not breakLoop+  when mainUIunderAI $+    handleUIunderAI side aid+  factNew <- getsState $ (EM.! side) . sfactionD+  let doQueryAI = not mainUIactor || gunderAI factNew+  breakASAP <- getsServer sbreakASAP+  -- If breaking out of the game loop, pretend there was a non-wait move.+  -- we don't need additionally to check @sbreakLoop@, because it occurs alone+  -- only via action of an actor and at most one action is performed here.+  if breakASAP then return True else do+    let mswitchLeader :: Maybe ActorId -> m ActorId+        {-# NOINLINE mswitchLeader #-}+        mswitchLeader (Just aidNew) = switchLeader side aidNew >> return aidNew+        mswitchLeader Nothing = return aid+    (aidNew, mtimed) <-+      if doQueryAI then do+        (cmd, maid) <- sendQueryAI side aid+        aidNew <- mswitchLeader maid+        mtimed <- handleRequestAI cmd+        return (aidNew, mtimed)+      else do+        (cmd, maid) <- sendQueryUI RespQueryUI side aid+        aidNew <- mswitchLeader maid+        mtimed <- handleRequestUI side aidNew cmd+        return (aidNew, mtimed)+    case mtimed of+      Just timed -> do+        nonWaitMove <- handleRequestTimed side aidNew timed+        -- Even if the actor got a free turn of time via a scroll,+        -- he will not act again this clip, only next clip.+        -- Clip is small, so not a big deal and it's faster and avoids+        -- complete game time freezes, e.g., due to an exploit.+        if nonWaitMove then return True else hActors rest+      Nothing -> do+        breakASAP2 <- getsServer sbreakASAP+        -- If breaking out of the game lopp, pretend there was a non-wait move.+        if breakASAP2 then return True else hActors as++handleUIunderAI :: (MonadServerAtomic m, MonadServerComm m)+                => FactionId -> ActorId -> m ()+handleUIunderAI side aid = do+  cmdS <- sendQueryUI RespQueryUIunderAI side aid+  case fst cmdS of+    ReqUINop -> return ()+    ReqUIAutomate -> execUpdAtomic $ UpdAutoFaction side False+    ReqUIGameDropAndExit -> reqGameDropAndExit aid+    ReqUIGameSaveAndExit -> reqGameSaveAndExit aid+    _ -> error $ "" `showFailure` cmdS++dieSer :: MonadServerAtomic m => ActorId -> Actor -> m ()+dieSer aid b2 = do+  if bproj b2 then+    when (isJust $ btrajectory b2) $+      execUpdAtomic $ UpdTrajectory aid (btrajectory b2) Nothing+        -- needed only to ensure display of the last position of projectile+  else do+    kindId <- getsState $ getIidKindIdServer $ btrunk b2+    execUpdAtomic $ UpdRecordKill aid kindId 1+    -- At this point the actor's body exists and his items are not dropped.+    deduceKilled aid+    -- Most probabaly already done, but just in case (e.g., when actor+    -- created with 0 HP):+    electLeader (bfid b2) (blid b2) aid+  -- If an explosion blast, before the particle is destroyed, it tries+  -- to modify terrain with it as well as do some easy crafting,+  -- e.g., cooking on fire.+  arTrunk <- getsState $ (EM.! btrunk b2) . sdiscoAspect+  let spentProj = bproj b2 && EM.null (beqp b2)+      isBlast = IA.checkFlag Ability.Blast arTrunk+      -- Let thrown food cook in fire (crafting) and other projectiles+      -- transform terrain they fall onto. Big actors are inert at death.+      (effScope, bumping) = if bproj b2+                            then (EffBareAndOnCombine, False)+                            else (EffBare, True)+  when (not spentProj && isBlast) $+    void $ reqAlterFail bumping effScope False aid (bpos b2)+  b3 <- getsState $ getActorBody aid+  -- Items need to do dropped now, so that they can be transformed by effects+  -- of the embedded items, if they are activated.+  -- If the actor was a projectile and no effect was triggered by hitting+  -- an enemy, the item still exists and @OnSmash@ effects will be triggered.+  dropAllEquippedItems aid b3+  -- Also destroy, not just drop, all organs, to trigger any effects.+  -- Note that some effects may be invoked on an actor that has+  -- no trunk any more. Conditions are ignored to avoid spam about them ending.+  bag <- getsState $ getBodyStoreBag b3 COrgan+  discoAspect <- getsState sdiscoAspect+  let f = void <$$> dropCStoreItem False True COrgan aid b3 maxBound+      isCondition = IA.checkFlag Ability.Condition . (discoAspect EM.!)+  mapM_ (uncurry f) $ filter (not . isCondition . fst) $ EM.assocs bag+  -- As the last act of heroism, the actor (even if projectile)+  -- changes the terrain with its embedded items, if possible.+  -- Note that all the resulting effects are invoked on an actor that has+  -- no trunk any more.+  when (not spentProj && not isBlast) $+    void $ reqAlterFail bumping effScope False aid (bpos b2)+      -- old bpos; OK, safer+  b4 <- getsState $ getActorBody aid+  execUpdAtomic $ UpdDestroyActor aid b4 []++restartGame :: MonadServerAtomic m+            => m () -> m () -> Maybe (GroupName ModeKind) -> m ()+restartGame updConn loop mgameMode = do+  -- This goes only to the old UI client.+  execSfxAtomic SfxRestart+  soptionsNxt <- getsServer soptionsNxt+  srandom <- getsServer srandom+  factionDold <- getsState sfactionD+  -- Create new factions.+  s <- gameReset soptionsNxt mgameMode (Just srandom)+  -- Note how we also no longer assert exploration, because there may not be+  -- enough time left in the debug run to explore again in a new game.+  let optionsBarRngs = soptionsNxt { sdungeonRng = Nothing+                                   , smainRng = Nothing+                                   , sassertExplored = Nothing }+  modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs+                             , soptions = optionsBarRngs }+  -- This reaches only the intersection of old and new clients.+  execUpdAtomic $ UpdRestartServer s+  -- Spawn new clients, as needed, according to new factions.+  updConn+  initPer+  reinitGame factionDold+  -- Save a just started noConfirm game to preserve history of the just+  -- ended normal game, in case the user exits brutally.+  writeSaveAll False True+  loop
+ engine-src/Game/LambdaHack/Server/MonadServer.hs view
@@ -0,0 +1,220 @@+-- | Basic server monads and related operations.+module Game.LambdaHack.Server.MonadServer+  ( -- * The server monad+    MonadServer( getsServer+               , modifyServer+               , chanSaveServer  -- exposed only to be implemented, not used+               , liftIO  -- exposed only to be implemented, not used+               )+  , MonadServerAtomic(..)+    -- * Assorted primitives+  , getServer, putServer, debugPossiblyPrint, debugPossiblyPrintAndExit+  , serverPrint, saveServer, dumpRngs, restoreScore, registerScore+  , rndToAction, getSetGen+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++-- Cabal+import qualified Paths_LambdaHack as Self (version)++import qualified Control.Exception as Ex+import qualified Control.Monad.Trans.State.Strict as St+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T+import qualified Data.Text.IO as T+import           Data.Time.Clock.POSIX+import           Data.Time.LocalTime+import           System.Exit (exitFailure)+import           System.FilePath+import           System.IO (hFlush, stdout)+import qualified System.Random.SplitMix32 as SM++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.ClientOptions (sbenchmark)+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.File+import qualified Game.LambdaHack.Common.HighScore as HighScore+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Core.Random+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++class MonadStateRead m => MonadServer m where+  getsServer     :: (StateServer -> a) -> m a+  modifyServer   :: (StateServer -> StateServer) -> m ()+  chanSaveServer :: m (Save.ChanSave (State, StateServer))+  -- We do not provide a MonadIO instance, so that outside+  -- nobody can subvert the action monads by invoking arbitrary IO.+  liftIO         :: IO a -> m a++-- | The monad for executing atomic game state transformations.+class MonadServer m => MonadServerAtomic m where+  -- | Execute an atomic command that changes the state+  -- on the server and on all clients that can notice it.+  execUpdAtomic :: UpdAtomic -> m ()+  -- | Execute an atomic command that changes the state+  -- on the server only.+  execUpdAtomicSer :: UpdAtomic -> m Bool+  -- | Execute an atomic command that changes the state+  -- on the given single client only.+  execUpdAtomicFid :: FactionId -> UpdAtomic -> m ()+  -- | Execute an atomic command that changes the state+  -- on the given single client only.+  -- Catch 'AtomicFail' and indicate if it was in fact raised.+  execUpdAtomicFidCatch :: FactionId -> UpdAtomic -> m Bool+  -- | Execute an atomic command that only displays special effects.+  execSfxAtomic :: SfxAtomic -> m ()+  execSendPer :: FactionId -> LevelId+              -> Perception -> Perception -> Perception -> m ()++getServer :: MonadServer m => m StateServer+getServer = getsServer id++putServer :: MonadServer m => StateServer -> m ()+putServer s = modifyServer (const s)++debugPossiblyPrint :: MonadServer m => Text -> m ()+debugPossiblyPrint t = do+  debug <- getsServer $ sdbgMsgSer . soptions+  when debug $ liftIO $ do+    T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough+    hFlush stdout++-- No moving savefiles aside, to debug more easily.+debugPossiblyPrintAndExit :: MonadServer m => Text -> m ()+debugPossiblyPrintAndExit t = do+  debug <- getsServer $ sdbgMsgSer . soptions+  when debug $ liftIO $ do+    T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough+    hFlush stdout+    exitFailure++serverPrint :: MonadServer m => Text -> m ()+serverPrint t = liftIO $ do+  T.hPutStr stdout $! t <> "\n"  -- hPutStrLn not atomic enough+  hFlush stdout++saveServer :: MonadServer m => m ()+saveServer = do+  s <- getState+  ser <- getServer+  toSave <- chanSaveServer+  liftIO $ Save.saveToChan toSave (s, ser)++-- | Dumps to stdout the RNG states from the start of the game.+dumpRngs :: MonadServer m => RNGs -> m ()+dumpRngs rngs = liftIO $ do+  T.hPutStr stdout $! tshow rngs <> "\n"  -- hPutStrLn not atomic enough+  hFlush stdout++-- | Read the high scores dictionary. Return the empty table if no file.+restoreScore :: forall m. MonadServer m => COps -> m HighScore.ScoreDict+restoreScore COps{corule} = do+  benchmark <- getsServer $ sbenchmark . sclientOptions . soptions+  mscore <- if benchmark then return Nothing else do+    let scoresFileName = rscoresFileName corule+    dataDir <- liftIO appDataDir+    let path bkp = dataDir </> bkp <> scoresFileName+    configExists <- liftIO $ doesFileExist (path "")+    res <- liftIO $ Ex.try $+      if configExists then do+        (vlib2, s) <- strictDecodeEOF (path "")+        if Save.compatibleVersion vlib2 Self.version+        then return $! s `seq` Just s+        else do+          let msg =+                "High score file from incompatible version of game detected."+          fail msg+      else return Nothing+    savePrefix <- getsServer $ ssavePrefixSer . soptions+    let defPrefix = ssavePrefixSer defServerOptions+        moveAside = savePrefix == defPrefix+        handler :: Ex.SomeException -> m (Maybe a)+        handler e = do+          when moveAside $+            liftIO $ renameFile (path "") (path "bkp.")+          let msg = "High score restore failed."+                    <+> (if moveAside+                        then "The wrong file moved aside."+                        else "")+                    <+> "The error message is:"+                    <+> (T.unwords . T.lines) (tshow e)+          serverPrint msg+          return Nothing+    either handler return res+  maybe (return HighScore.empty) return mscore++-- | Generate a new score, register it and save.+registerScore :: MonadServer m => Status -> FactionId -> m ()+registerScore status fid = do+  cops@COps{corule} <- getsState scops+  total <- getsState $ snd . calculateTotal fid+  let scoresFileName = rscoresFileName corule+  dataDir <- liftIO appDataDir+  -- Re-read the table in case it's changed by a concurrent game.+  scoreDict <- restoreScore cops+  gameModeId <- getsState sgameModeId+  time <- getsState stime+  dungeonTotal <- getsState sgold+  date <- liftIO getPOSIXTime+  tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date+  curChalSer <- getsServer $ scurChalSer . soptions+  factionD <- getsState sfactionD+  bench <- getsServer $ sbenchmark . sclientOptions . soptions+  noConfirmsGame <- isNoConfirmsGame+  sbandSpawned <- getsServer sbandSpawned+  let fact = factionD EM.! fid+      path = dataDir </> scoresFileName+      outputScore (worthMentioning, (ntable, pos)) =+        -- If testing or fooling around, dump instead of registering.+        -- In particular don't register score for the auto-* scenarios.+        if bench || noConfirmsGame || gunderAI fact then+          debugPossiblyPrint $ T.intercalate "\n"+          $ HighScore.showScore tz pos (HighScore.getRecord pos ntable)+            ++ ["           Spawned groups:"+                <+> T.unwords (tail (T.words (tshow sbandSpawned)))]+        else+          let nScoreDict = EM.insert gameModeId ntable scoreDict+          in when worthMentioning $ liftIO $+               encodeEOF path Self.version (nScoreDict :: HighScore.ScoreDict)+      theirVic (fi, fa) | isFoe fid fact fi+                          && not (isHorrorFact fa) = Just $ gvictims fa+                        | otherwise = Nothing+      theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD+      ourVic (fi, fa) | isFriend fid fact fi = Just $ gvictims fa+                      | otherwise = Nothing+      ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD+      table = HighScore.getTable gameModeId scoreDict+      registeredScore =+        HighScore.register table total dungeonTotal time status date curChalSer+                           (T.unwords $ tail $ T.words $ gname fact)+                           ourVictims theirVictims+                           (fhiCondPoly $ gkind fact)+  outputScore registeredScore++-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: MonadServer m => Rnd a -> m a+rndToAction r = do+  gen1 <- getsServer srandom+  let (a, gen2) = St.runState r gen1+  modifyServer $ \ser -> ser {srandom = gen2}+  return a++-- | Gets a random generator from the user-submitted options or, if not present,+-- generates one.+getSetGen :: MonadServer m => Maybe SM.SMGen -> m SM.SMGen+getSetGen mrng = case mrng of+  Just rnd -> return rnd+  Nothing -> liftIO SM.newSMGen
+ engine-src/Game/LambdaHack/Server/PeriodicM.hs view
@@ -0,0 +1,491 @@+-- | Server operations performed periodically in the game loop+-- and related operations.+module Game.LambdaHack.Server.PeriodicM+  ( spawnMonster, addManyActors+  , advanceTime, advanceTimeTraj, overheadActorTime, swapTime+  , updateCalm, leadLevelSwitch+  , endOrLoop+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , addAnyActor, rollSpawnPos, gameExit+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Int (Int64)+import qualified Data.IntMap.Strict as IM+import qualified Data.Text as T++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.CaveKind as CK+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Server.CommonM+import           Game.LambdaHack.Server.ItemM+import           Game.LambdaHack.Server.ItemRev+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.ProtocolM+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++-- | Spawn, possibly, a monster according to the level's actor groups.+-- We assume heroes are never spawned.+spawnMonster :: MonadServerAtomic m => m ()+spawnMonster = do+ COps{cocave} <- getsState scops+ arenas <- getsServer sarenas+ unless (ES.null arenas) $ do+  -- Do this on only one of the arenas to prevent micromanagement,+  -- e.g., spreading leaders across levels to bump monster generation.+  arena <- rndToAction $ oneOf $ ES.elems arenas+  Level{lkind, ldepth, lbig, ltime=localTime} <- getLevel arena+  let ck = okind cocave lkind+  if | CK.cactorCoeff ck == 0 || null (CK.cactorFreq ck) -> return ()+     | EM.size lbig >= 300 ->  -- probably not so rare, but debug anyway+       -- Gameplay consideration: not fun to slog through so many actors.+       -- Caves rarely start with more than 100.+       debugPossiblyPrint "Server: spawnMonster: too many big actors on level"+     | otherwise -> do+       totalDepth <- getsState stotalDepth+       lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup arena . snumSpawned+       let perMillion =+             monsterGenChance ldepth totalDepth lvlSpawned (CK.cactorCoeff ck)+           million = 1000000+       k <- rndToAction $ randomR (1, million)+       when (k <= perMillion && localTime > timeTurn) $ do+         let numToSpawn | 25 * k <= perMillion = 3+                        | 10 * k <= perMillion = 2+                        | otherwise = 1+             alt Nothing = Just 1+             alt (Just n) = Just $ n + 1+         modifyServer $ \ser ->+           ser { snumSpawned = EM.insert arena (lvlSpawned + numToSpawn)+                               $ snumSpawned ser+               , sbandSpawned = IM.alter alt numToSpawn+                                $ sbandSpawned ser }+         void $ addManyActors False lvlSpawned (CK.cactorFreq ck) arena+                              localTime Nothing numToSpawn++addAnyActor :: MonadServerAtomic m+            => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point+            -> m (Maybe (ActorId, Point))+addAnyActor summoned lvlSpawned actorFreq lid time mpos = do+  -- We bootstrap the actor by first creating the trunk of the actor's body+  -- that contains the fixed properties of all actors of that kind.+  cops <- getsState scops+  lvl@Level{ldepth} <- getLevel lid+  factionD <- getsState sfactionD+  freq <- prepareItemKind lvlSpawned ldepth actorFreq+  m2 <- rollItemAspect freq ldepth+  case m2 of+    NoNewItem -> do+      debugPossiblyPrint $ T.pack $+        "Server: addAnyActor: trunk failed to roll"+        `showFailure` (summoned, lvlSpawned, actorFreq, freq, lid, time, mpos)+      return Nothing+    NewItem itemGroup itemKnownRaw itemFullRaw itemQuant -> do+      (fid, _) <- rndToAction $ frequency $+                    possibleActorFactions [itemGroup] (itemKind itemFullRaw)+                                          factionD+      let fact = factionD EM.! fid+      if isJust $ gquit fact+      then return Nothing  -- the faction that spawns the monster is dead+      else do+        pers <- getsServer sperFid+        let allPers = ES.unions $ map (totalVisible . (EM.! lid))+                      $ EM.elems $ EM.delete fid pers  -- expensive :(+            -- Checking skill would be more accurate, but skills can be+            -- inside organs, equipment, condition organs, created organs, etc.+            freqNames = map fst $ IK.ifreq $ itemKind itemFullRaw+            mobile = IK.MOBILE `elem` freqNames+            aquatic = IK.AQUATIC `elem` freqNames+        mrolledPos <- case mpos of+          Just{} -> return mpos+          Nothing -> do+            rollPos <-+              getsState $ rollSpawnPos cops allPers mobile aquatic lid lvl fid+            rndToAction rollPos+        case mrolledPos of+          Just pos ->+            Just . (\aid -> (aid, pos))+            <$> registerActor summoned itemKnownRaw (itemFullRaw, itemQuant)+                              fid pos lid time+          Nothing -> do+            debugPossiblyPrint+              "Server: addAnyActor: failed to find any free position"+            return Nothing++addManyActors :: MonadServerAtomic m+              => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point+              -> Int+              -> m Bool+addManyActors summoned lvlSpawned actorFreq lid time mpos+              howMany = assert (howMany >= 1) $ do+  mInitialLAidPos <- case mpos of+    Just pos -> return $ Just ([], pos)+    Nothing ->+      (\(aid, pos) -> ([aid], pos))+      <$$> addAnyActor summoned lvlSpawned actorFreq lid time Nothing+  case mInitialLAidPos of+    Nothing -> return False  -- suspect content; server debug elsewhere+    Just (laid, pos) -> do+      cops@COps{coTileSpeedup} <- getsState scops+      lvl <- getLevel lid+      let validTile t = not $ Tile.isNoActor coTileSpeedup t+          ps = nearbyFreePoints cops lvl validTile pos+          psNeeded = take (howMany - length laid) ps+      when (length psNeeded < howMany - length laid) $+        debugPossiblyPrint $+          "Server: addManyActors: failed to find enough free positions at"+          <+> tshow (lid, pos)+      maidposs <- forM psNeeded $+        addAnyActor summoned lvlSpawned actorFreq lid time . Just+      case laid ++ map fst (catMaybes maidposs) of+        [] -> return False+        aid : _ -> do+          b <- getsState $ getActorBody aid+          mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD+          when (isNothing mleader) $ setFreshLeader (bfid b) aid+          return True++rollSpawnPos :: COps -> ES.EnumSet Point+             -> Bool -> Bool -> LevelId -> Level -> FactionId -> State+             -> Rnd (Maybe Point)+rollSpawnPos COps{coTileSpeedup} visible+             mobile aquatic lid lvl@Level{larea} fid s = do+  let inhabitants = foeRegularList fid lid s+      nearInh !d !p = any (\ !b -> chessDist (bpos b) p < d) inhabitants+      farInh !d !p = all (\ !b -> chessDist (bpos b) p > d) inhabitants+      (_, xspan, yspan) = spanArea larea+      averageSpan = (xspan + yspan) `div` 2+      distantMiddle !d !p = chessDist p (middlePoint larea) < d+      -- Don't spawn very far from foes, to keep the player entertained,+      -- but not too close, so that standing on positions with better+      -- visibility does not influence the spawn places too often,+      -- to avoid unnatural position micromanagement using AI predictability.+      condList | mobile =+        [ \p -> nearInh (max 15 $ averageSpan `div` 2) p+                && farInh 10 p+        , \p -> nearInh (max 15 $ 2 * averageSpan `div` 3) p+                && farInh 5 p+        ]+               | otherwise =+        [ distantMiddle 8+        , distantMiddle 16+        , distantMiddle 24+        , distantMiddle 26+        , distantMiddle 28+        , distantMiddle 30+        ]+  -- Not considering TK.OftenActor, because monsters emerge from hidden ducts,+  -- which are easier to hide in crampy corridors that lit halls.+  findPosTry2 (if mobile then 500 else 50) lvl+    ( \p !t -> Tile.isWalkable coTileSpeedup t+               && not (Tile.isNoActor coTileSpeedup t)+               && not (occupiedBigLvl p lvl)+               && not (occupiedProjLvl p lvl) )+    (map (\f p _ -> f p) condList)+    (\ !p t -> farInh 3 p  -- otherwise actors in dark rooms swarmed+               && not (p `ES.member` visible)  -- visibility and plausibility+               && (not aquatic || Tile.isAquatic coTileSpeedup t))+    [ \ !p _ -> farInh 3 p+                && not (p `ES.member` visible)+    , \ !p _ -> farInh 2 p  -- otherwise actors hit on entering level+                && not (p `ES.member` visible)+    , \ !p _ -> not (p `ES.member` visible)+    ]++-- | Advance the move time for the given actor.+advanceTime :: MonadServerAtomic m => ActorId -> Int -> Bool -> m ()+advanceTime aid percent breakStasis = do+  b <- getsState $ getActorBody aid+  actorMaxSk <- getsState $ getActorMaxSkills aid+  let t = timeDeltaPercent (ticksPerMeter $ gearSpeed actorMaxSk) percent+  -- @t@ may be negative; that's OK.+  modifyServer $ \ser ->+    ser {sactorTime = ageActor (bfid b) (blid b) aid t $ sactorTime ser}+  when breakStasis $+    modifyServer $ \ser ->+      ser {sactorStasis = ES.delete aid (sactorStasis ser)}+             -- actor moved, so he broke the time stasis, he can be+             -- paralyzed as well as propelled again++-- | Advance the trajectory following time for the given actor.+advanceTimeTraj :: MonadServerAtomic m => ActorId -> m ()+advanceTimeTraj aid = do+  b <- getsState $ getActorBody aid+  let speedTraj = case btrajectory b of+        Nothing -> error $ "" `showFailure` b+        Just (_, speed) -> speed+      t = ticksPerMeter speedTraj+  -- @t@ may be negative; that's OK.+  modifyServer $ \ser ->+    ser {strajTime = ageActor (bfid b) (blid b) aid t $ strajTime ser}++-- | Add communication overhead time delta to all non-projectile, non-dying+-- faction's actors, except the leader. Effectively, this limits moves+-- of a faction on a level to 10, regardless of the number of actors+-- and their speeds. To avoid animals suddenly acting extremely sluggish+-- whenever monster's leader visits a distant arena that has a crowd+-- of animals, overhead applies only to actors on the same level.+-- Since the number of active levels is limited, this bounds the total moves+-- per turn of each faction as well.+--+-- Leader is immune from overhead and so he is faster than other faction+-- members and of equal speed to leaders of other factions (of equal+-- base speed) regardless how numerous the faction is.+-- Thanks to this, there is no problem with leader of a numerous faction+-- having very long UI turns, introducing UI lag.+overheadActorTime :: MonadServerAtomic m => FactionId -> LevelId -> m ()+overheadActorTime fid lid = do+  -- Only non-projectiles processed, because @strajTime@ ignored.+  actorTimeFid <- getsServer $ (EM.! fid) . sactorTime+  let actorTimeLid = actorTimeFid EM.! lid+  getActorB <- getsState $ flip getActorBody+  mleader <- getsState $ gleader . (EM.! fid) . sfactionD+  let f !aid !time =+        let body = getActorB aid+        in if bhp body > 0  -- speed up all-move-at-once carcass removal+              && Just aid /= mleader  -- leader fast, for UI to be fast+           then timeShift time (Delta timeClip)+           else time+      actorTimeLid2 = EM.mapWithKey f actorTimeLid+      actorTimeFid2 = EM.insert lid actorTimeLid2 actorTimeFid+  modifyServer $ \ser ->+    ser {sactorTime = EM.insert fid actorTimeFid2 $ sactorTime ser}++-- | Swap the relative move times of two actors (e.g., when switching+-- a UI leader). Notice that their trajectory move times are not swapped.+swapTime :: MonadServerAtomic m => ActorId -> ActorId -> m ()+swapTime source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  slvl <- getsState $ getLocalTime (blid sb)+  tlvl <- getsState $ getLocalTime (blid tb)+  btime_sb <-+    getsServer+    $ fromJust . lookupActorTime (bfid sb) (blid sb) source . sactorTime+  btime_tb <-+    getsServer+    $ fromJust . lookupActorTime (bfid tb) (blid tb) target . sactorTime+  let lvlDelta = slvl `timeDeltaToFrom` tlvl+      bDelta = btime_sb `timeDeltaToFrom` btime_tb+      sdelta = timeDeltaSubtract lvlDelta bDelta+      tdelta = timeDeltaReverse sdelta+  -- Equivalent, for the assert:+  let !_A = let sbodyDelta = btime_sb `timeDeltaToFrom` slvl+                tbodyDelta = btime_tb `timeDeltaToFrom` tlvl+                sgoal = slvl `timeShift` tbodyDelta+                tgoal = tlvl `timeShift` sbodyDelta+                sdelta' = sgoal `timeDeltaToFrom` btime_sb+                tdelta' = tgoal `timeDeltaToFrom` btime_tb+            in assert (sdelta == sdelta' && tdelta == tdelta'+                       `blame` ( slvl, tlvl, btime_sb, btime_tb+                               , sdelta, sdelta', tdelta, tdelta' )) ()+  when (sdelta /= Delta timeZero) $ modifyServer $ \ser ->+    ser {sactorTime = ageActor (bfid sb) (blid sb) source sdelta+                      $ sactorTime ser}+  when (tdelta /= Delta timeZero) $ modifyServer $ \ser ->+    ser {sactorTime = ageActor (bfid tb) (blid tb) target tdelta+                      $ sactorTime ser}++updateCalm :: MonadServerAtomic m => ActorId -> Int64 -> m ()+updateCalm target deltaCalm = do+  tb <- getsState $ getActorBody target+  actorMaxSk <- getsState $ getActorMaxSkills target+  let calmMax64 = xM $ Ability.getSk Ability.SkMaxCalm actorMaxSk+  execUpdAtomic $ UpdRefillCalm target deltaCalm+  when (bcalm tb < calmMax64+        && bcalm tb + deltaCalm >= calmMax64) $+    return ()+    -- We don't dominate the actor here, because if so, players would+    -- disengage after one of their actors is dominated and wait for him+    -- to regenerate Calm. This is unnatural and boring. Better fight+    -- and hope he gets his Calm again to 0 and then defects back.+    -- We could instead tell here that Calm is fully regenerated,+    -- but that would be too verbose.++leadLevelSwitch :: MonadServerAtomic m => m ()+leadLevelSwitch = do+  COps{cocave} <- getsState scops+  factionD <- getsState sfactionD+  -- Leader switching between levels can be done by the client+  -- (e.g,. UI client of the human) or by the server+  -- (the frequency of leader level switching done by the server+  -- is controlled by @RuleKind.rleadLevelClips@). Regardless, the server+  -- alwayw does a subset of the switching, e.g., when the old leader dies+  -- and no other actor of the faction resides on his level.+  -- Here we check if the server is permitted to handle the mundane cases.+  let serverMaySwitch fact =+        bannedPointmanSwitchBetweenLevels fact+          -- client banned from switching, so the sever has to step in+        || gunderAI fact+             -- a hack to help AI, until AI client can switch levels+      flipFaction (_, fact) | not $ serverMaySwitch fact = return ()+      flipFaction (fid, fact) =+        case gleader fact of+          Nothing -> return ()+          Just leader -> do+            body <- getsState $ getActorBody leader+            let !_A = assert (fid == bfid body) ()+            s <- getsServer $ (EM.! fid) . sclientStates+            let leaderStuck = actorWaits body+                lvlsRaw =+                  [ ((lid, lvl), (allSeen, as))+                  | (lid, lvl) <- EM.assocs $ sdungeon s+                  , lid /= blid body || not leaderStuck+                  , let asRaw = -- Drama levels ignored, hence @Regular@.+                                fidActorRegularAssocs fid lid s+                        isAlert (_, b) = case bwatch b of+                          WWatch -> True+                          WWait n -> n == 0+                          WSleep -> False+                          WWake -> True  -- probably in danger+                        (alert, relaxed) = partition isAlert asRaw+                        as = alert ++ relaxed  -- best switch leader to alert+                  , not (null as)+                  , let allSeen =+                          lexpl lvl <= lseen lvl+                          || CK.cactorCoeff (okind cocave $ lkind lvl) > 150+                             && not (fhasGender $ gkind fact)+                  ]+                (lvlsSeen, lvlsNotSeen) = partition (fst . snd) lvlsRaw+                -- Monster AI changes leadership mostly to move from level+                -- to level and, in particular, to quickly bring troops+                -- to the frontline level and so prevent human from killing+                -- monsters at numerical advantage.+                -- However, an AI boss that can't move between levels+                -- disrupts this by hogging leadership. To prevent that,+                -- assuming the boss resides below the frontline level,+                -- only the two shallowest levels that are not yet fully+                -- explored are considered to choose the new leader from.+                -- This frontier moves as the levels are explored or emptied+                -- and sometimes the level with the boss is counted among+                -- them, but it never happens in the crucial periods when+                -- AI armies are transferred from level to level.+                f ((_, lvl), _) = ldepth lvl+                lvls = lvlsSeen ++ take 2 (sortBy (comparing f) lvlsNotSeen)+            -- Actors on desolate levels (not many own or enemy non-projectiles)+            -- tend to become (or stay) leaders so that they can join the main+            -- force where it matters ASAP. Unfortunately, this keeps hero+            -- scouts as leader, but foes spawn very fast early on ,+            -- so they give back leadership rather quickly to let others follow.+            -- We count non-mobile and sleeping actors, because they may+            -- be dangerous, especially if adjacent to stairs.+            let overOwnStash b = Just (blid b, bpos b) == gstash fact+                freqList = [ (k, (lid, aid))+                           | ((lid, lvl), (_, (aid, b) : rest)) <- lvls+                           , let len = min 20 (EM.size $ lbig lvl)+                                 n = 1000000 `div` (1 + len)+                                 -- Visit the stash guard rarely, but not too+                                 -- rarely, to regen Calm and fling at foes.+                                 k = max 1 $ if null rest && overOwnStash b+                                             then n `div` 30+                                             else n+                           ]+                closeToFactStash (fid2, fact2) = case gstash fact2 of+                  Just (lid, pos) ->+                    (fid == fid2 || isFoe fid (factionD EM.! fid) fid2)+                    && lid == blid body+                    && chessDist pos (bpos body) == 1  -- visible+                  Nothing -> False+                closeToEnemyStash = any closeToFactStash $ EM.assocs factionD+            foes <- getsState $ foeRegularList fid (blid body)+            ours <- getsState $ map snd+                                <$> fidActorRegularAssocs fid (blid body)+            let foesClose = filter (\b -> chessDist (bpos body) (bpos b) <= 2)+                                   foes+                oursCloseMelee =+                  filter (\b -> chessDist (bpos body) (bpos b) <= 2+                                && bweapon b - bweapBenign b > 0)+                         ours+                canHelpMelee =+                  not leaderStuck+                  && length oursCloseMelee >= 2+                  && not (null foesClose)+                  && not (all (\b -> any (adjacent (bpos b) . bpos) foes)+                              oursCloseMelee)+            unless (closeToEnemyStash || canHelpMelee || null freqList) $ do+              (lid, a) <- rndToAction $ frequency+                                      $ toFreq "leadLevel" freqList+              unless (lid == blid body) $  -- flip levels rather than actors+                setFreshLeader fid a+  mapM_ flipFaction $ EM.assocs factionD++-- | Continue or exit or restart the game.+endOrLoop :: (MonadServerAtomic m, MonadServerComm m)+          => m () -> (Maybe (GroupName ModeKind) -> m ())+          -> m ()+{-# INLINE endOrLoop #-}+endOrLoop loop restart = do+  factionD <- getsState sfactionD+  let inGame fact = case gquit fact of+        Nothing -> True+        Just Status{stOutcome=Camping} -> True+        _ -> False+      gameOver = not $ any inGame $ EM.elems factionD+  let getQuitter fact = case gquit fact of+        Just Status{stOutcome=Restart, stNewGame} -> stNewGame+        _ -> Nothing+      quitters = mapMaybe getQuitter $ EM.elems factionD+      restartNeeded = gameOver || not (null quitters)+  let isCamper fact = case gquit fact of+        Just Status{stOutcome=Camping} -> True+        _ -> False+      campers = filter (isCamper . snd) $ EM.assocs factionD+  -- Wipe out the quit flag for the savegame files.+  mapM_ (\(fid, fact) ->+    execUpdAtomic $ UpdQuitFaction fid (gquit fact) Nothing Nothing) campers+  swriteSave <- getsServer swriteSave+  sstopAfterGameOver <-+    getsServer $ sstopAfterGameOver . soptions+  when swriteSave $ do+    modifyServer $ \ser -> ser {swriteSave = False}+    writeSaveAll True False+  if | gameOver && sstopAfterGameOver -> gameExit+     | restartNeeded -> restart (listToMaybe quitters)+     | not $ null campers -> gameExit  -- and @loop@ is not called+     | otherwise -> loop  -- continue current game++gameExit :: (MonadServerAtomic m, MonadServerComm m) => m ()+gameExit = do+--  debugPossiblyPrint "Server: Verifying all perceptions."+  -- Verify that the possibly not saved caches are equal to future+  -- reconstructed. Otherwise, save/restore would change game state.+  -- This is done even in released binaries, because it only prolongs+  -- game shutdown a bit. The same checks at each periodic game save+  -- would icrease the game saving lag, so they are normally avoided.+  verifyCaches+  -- Kill all clients, including those that did not take part+  -- in the current game.+  -- Clients exit not now, but after they print all ending screens.+--  debugPossiblyPrint "Server: Killing all clients."+  killAllClients+--  debugPossiblyPrint "Server: All clients killed."+  return ()
+ engine-src/Game/LambdaHack/Server/ProtocolM.hs view
@@ -0,0 +1,241 @@+-- | The server definitions for the server-client communication protocol.+module Game.LambdaHack.Server.ProtocolM+  ( -- * The communication channels+    CliSerQueue, ConnServerDict, ChanServer(..)+    -- * The server-client communication monad+  , MonadServerComm+      ( getsDict  -- exposed only to be implemented, not used+      , putDict  -- exposed only to be implemented, not used+      , liftIO  -- exposed only to be implemented, not used+      )+    -- * Protocol+  , sendUpdate, sendUpdateCheck, sendUpdNoState+  , sendSfx, sendQueryAI, sendQueryUI+    -- * Assorted+  , killAllClients, childrenServer, updateConn, tryRestore+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , writeQueue, readQueueAI, readQueueUI, newQueue+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Concurrent+import           Control.Concurrent.Async+import qualified Data.EnumMap.Strict as EM+import           Data.Key (mapWithKeyM_)+import           System.FilePath+import           System.IO.Unsafe (unsafePerformIO)++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client (RequestAI, RequestUI, Response (..))+import           Game.LambdaHack.Common.ClientOptions (sbenchmark)+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.File+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import qualified Game.LambdaHack.Common.Save as Save+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Thread+import           Game.LambdaHack.Common.Types+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Server.DebugM+import           Game.LambdaHack.Server.MonadServer hiding (liftIO)+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++writeQueue :: MonadServerComm m+           => Response -> CliSerQueue Response -> m ()+{-# INLINE writeQueue #-}+writeQueue cmd responseS = liftIO $ putMVar responseS cmd++readQueueAI :: MonadServerComm m+            => CliSerQueue RequestAI -> m RequestAI+{-# INLINE readQueueAI #-}+readQueueAI requestS = liftIO $ takeMVar requestS++readQueueUI :: MonadServerComm m+            => CliSerQueue RequestUI -> m RequestUI+{-# INLINE readQueueUI #-}+readQueueUI requestS = liftIO $ takeMVar requestS++newQueue :: IO (CliSerQueue a)+newQueue = newEmptyMVar++type CliSerQueue = MVar++-- | Connection information for all factions, indexed by faction identifier.+type ConnServerDict = EM.EnumMap FactionId ChanServer++-- | Connection channel between the server and a single client.+data ChanServer = ChanServer+  { responseS  :: CliSerQueue Response+  , requestAIS :: CliSerQueue RequestAI+  , requestUIS :: Maybe (CliSerQueue RequestUI)+  }++-- | The server monad with the ability to communicate with clients.+class MonadServer m => MonadServerComm m where+  getsDict       :: (ConnServerDict -> a) -> m a+  putDict        :: ConnServerDict -> m ()+  liftIO         :: IO a -> m a++getDict :: MonadServerComm m => m ConnServerDict+getDict = getsDict id++-- | If the @AtomicFail@ conditions hold, send a command to client,+-- otherwise do nothing.+sendUpdate :: (MonadServerAtomic m, MonadServerComm m)+           => FactionId -> UpdAtomic -> m ()+sendUpdate !fid !cmd = do+  succeeded <- execUpdAtomicFidCatch fid cmd+  when succeeded $ sendUpd fid cmd++-- | Send a command to client, crashing if the @AtomicFail@ conditions+-- don't hold when executed on the client's state.+sendUpdateCheck :: (MonadServerAtomic m, MonadServerComm m)+                => FactionId -> UpdAtomic -> m ()+sendUpdateCheck !fid !cmd = do+  execUpdAtomicFid fid cmd+  sendUpd fid cmd++sendUpd :: MonadServerComm m => FactionId -> UpdAtomic -> m ()+sendUpd !fid !cmd = do+  chan <- getsDict (EM.! fid)+  s <- getsServer $ (EM.! fid) . sclientStates+  let resp = RespUpdAtomic s cmd+  debug <- getsServer $ sniff . soptions+  when debug $ debugResponse fid resp+  writeQueue resp $ responseS chan++sendUpdNoState :: MonadServerComm m => FactionId -> UpdAtomic -> m ()+sendUpdNoState !fid !cmd = do+  chan <- getsDict (EM.! fid)+  let resp = RespUpdAtomicNoState cmd+  debug <- getsServer $ sniff . soptions+  when debug $ debugResponse fid resp+  writeQueue resp $ responseS chan++sendSfx :: MonadServerComm m => FactionId -> SfxAtomic -> m ()+sendSfx !fid !sfx = do+  let resp = RespSfxAtomic sfx+  debug <- getsServer $ sniff . soptions+  when debug $ debugResponse fid resp+  chan <- getsDict (EM.! fid)+  case chan of+    ChanServer{requestUIS=Just{}} -> writeQueue resp $ responseS chan+    _ -> return ()++sendQueryAI :: MonadServerComm m => FactionId -> ActorId -> m RequestAI+sendQueryAI fid aid = do+  let respAI = RespQueryAI aid+  debug <- getsServer $ sniff . soptions+  when debug $ debugResponse fid respAI+  chan <- getsDict (EM.! fid)+  req <- do+    writeQueue respAI $ responseS chan+    readQueueAI $ requestAIS chan+  when debug $ debugRequestAI aid+  return req++sendQueryUI :: (MonadServerAtomic m, MonadServerComm m)+            => Response -> FactionId -> ActorId -> m RequestUI+sendQueryUI respUI fid _aid = do+  debug <- getsServer $ sniff . soptions+  when debug $ debugResponse fid respUI+  chan <- getsDict (EM.! fid)+  req <- do+    writeQueue respUI $ responseS chan+    readQueueUI $ fromJust $ requestUIS chan+  when debug $ debugRequestUI _aid+  return req++killAllClients :: (MonadServerAtomic m, MonadServerComm m) => m ()+killAllClients = do+  d <- getDict+  let sendKill fid _ = sendUpdNoState fid $ UpdKillExit fid+  -- We can't interate over sfactionD, because client can be from an old game.+  -- For the same reason we can't look up and send client's state.+  mapWithKeyM_ sendKill d++-- Global variable for all children threads of the server.+childrenServer :: MVar [Async ()]+{-# NOINLINE childrenServer #-}+childrenServer = unsafePerformIO (newMVar [])++-- | Update connections to the new definition of factions.+-- Connect to clients in old or newly spawned threads+-- that read and write directly to the channels.+updateConn :: (MonadServerAtomic m, MonadServerComm m)+           => (FactionId -> ChanServer -> IO ())+           -> m ()+updateConn executorClient = do+  -- Prepare connections based on factions.+  oldD <- getDict+  let mkChanServer :: Faction -> IO ChanServer+      mkChanServer fact = do+        responseS <- newQueue+        requestAIS <- newQueue+        requestUIS <- if fhasUI $ gkind fact+                      then assert (EM.null oldD) $ Just <$> newQueue+                      else return Nothing+        return ChanServer{..}+      forkClient fid = forkChild childrenServer . executorClient fid+  factionD <- getsState sfactionD+  if EM.null oldD then do+    -- Easy case, nothing to recycle, frontend not spawned yet.+    newD <- liftIO $ mapM mkChanServer factionD+    putDict newD+    liftIO $ mapWithKeyM_ forkClient newD+  else do+    -- Hard case, but we know there is exactly one UI connection in oldD,+    -- so we can reuse it for any new UI faction (to keep history).+    -- UI session (history in particular) is preserved even over game+    -- save and reload. It gets saved with the savefile of the team+    -- that is a UI faction and restored intact. However, when a new game+    -- is started from commandline (@--newGame@), even if it's using the same+    -- save prefix (@--savePrefix@), the session data is often lost.+    -- AI factions don't care which client they use, so we don't always+    -- preserve the old assignments either of factions or teams.+    let -- Find the new UI faction.+        (fidUI, _) = fromJust $ find (fhasUI . gkind . snd) $ EM.assocs factionD+        -- Swap UI and AI connections around.+        swappedD = case find (isJust . requestUIS . snd)+                               $ EM.assocs oldD of+          Nothing -> error "updateConn: no UI connection found"+          Just (fid, conn) ->+            if fid == fidUI+            then oldD  -- UI connection at the same place; nothing to do+            else let -- Move the AI connection that was at new UI faction spot,+                     -- to the freed old UI spot.+                     alt _ = EM.lookup fidUI oldD+                 in EM.alter alt fid $ EM.insert fidUI conn oldD+        -- Add extra AI connections.+        extraFacts = EM.filterWithKey (\fid _ -> EM.notMember fid swappedD)+                                      factionD+    extraD <- liftIO $ mapM mkChanServer extraFacts+    let exclusiveUnion = EM.unionWith $ \_ _ -> error "forbidden duplicate"+        newD = swappedD `exclusiveUnion` extraD+    putDict newD+    -- Spawn the extra AI client threads.+    liftIO $ mapWithKeyM_ forkClient extraD++tryRestore :: MonadServerComm m => m (Maybe (State, StateServer))+tryRestore = do+  COps{corule} <- getsState scops+  soptions <- getsServer soptions+  if sbenchmark $ sclientOptions soptions then return Nothing+  else do+    let prefix = ssavePrefixSer soptions+        fileName = prefix <> Save.saveNameSer corule+    res <- liftIO $ Save.restoreGame corule (sclientOptions soptions) fileName+    let cfgUIName = rcfgUIName corule+        (configText, _) = rcfgUIDefault corule+    dataDir <- liftIO appDataDir+    liftIO $ tryWriteFile (dataDir </> cfgUIName) configText+    return $! res
+ engine-src/Game/LambdaHack/Server/ServerOptions.hs view
@@ -0,0 +1,132 @@+-- | Server and client game state types and operations.+module Game.LambdaHack.Server.ServerOptions+  ( ServerOptions(..), RNGs(..), defServerOptions+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified System.Random.SplitMix32 as SM++import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Definition.Defs++-- | Options that affect the behaviour of the server (including game rules).+data ServerOptions = ServerOptions+  { sknowMap           :: Bool+  , sknowEvents        :: Bool+  , sknowItems         :: Bool+  , sniff              :: Bool+  , sallClear          :: Bool+  , sboostRandomItem   :: Bool+  , sgameMode          :: Maybe (GroupName ModeKind)+  , sautomateAll       :: Bool+  , skeepAutomated     :: Bool+  , sdungeonRng        :: Maybe SM.SMGen+  , smainRng           :: Maybe SM.SMGen+  , snewGameSer        :: Bool+  , scurChalSer        :: Challenge+  , sdumpInitRngs      :: Bool+  , ssavePrefixSer     :: String+  , sdbgMsgSer         :: Bool+  , sassertExplored    :: Maybe Int+  , sshowItemSamples   :: Bool+  , sstopAfterGameOver :: Bool+  , sclientOptions     :: ClientOptions+      -- The client debug inside server debug only holds the client commandline+      -- options and is never updated with config options, etc.+  }+  deriving Show++data RNGs = RNGs+  { dungeonRandomGenerator  :: Maybe SM.SMGen+  , startingRandomGenerator :: Maybe SM.SMGen+  }++instance Show RNGs where+  show RNGs{..} =+    let args = [ maybe "" (\gen -> "--setDungeonRng \"" ++ show gen ++ "\"")+                       dungeonRandomGenerator+               , maybe "" (\gen -> "--setMainRng \"" ++ show gen ++ "\"")+                       startingRandomGenerator ]+    in unwords args++instance Binary ServerOptions where+  put ServerOptions{..} = do+    put sknowMap+    put sknowEvents+    put sknowItems+    put sniff+    put sallClear+    put sboostRandomItem+    put sgameMode+    put sautomateAll+    put skeepAutomated+    put scurChalSer+    put ssavePrefixSer+    put sdbgMsgSer+    put sassertExplored+    put sshowItemSamples+    put sclientOptions+  get = do+    sknowMap <- get+    sknowEvents <- get+    sknowItems <- get+    sniff <- get+    sallClear <- get+    sboostRandomItem <- get+    sgameMode <- get+    sautomateAll <- get+    skeepAutomated <- get+    scurChalSer <- get+    ssavePrefixSer <- get+    sdbgMsgSer <- get+    sassertExplored <- get+    sshowItemSamples <- get+    sclientOptions <- get+    let sdungeonRng = Nothing+        smainRng = Nothing+        snewGameSer = False+        sdumpInitRngs = False+        sstopAfterGameOver = False+    return $! ServerOptions{..}++instance Binary RNGs where+  put RNGs{..} = do+    put (show dungeonRandomGenerator)+    put (show startingRandomGenerator)+  get = do+    dg <- get+    sg <- get+    let dungeonRandomGenerator = read dg+        startingRandomGenerator = read sg+    return $! RNGs{..}++-- | Default value of server options.+defServerOptions :: ServerOptions+defServerOptions = ServerOptions+  { sknowMap = False+  , sknowEvents = False+  , sknowItems = False+  , sniff = False+  , sallClear = False+  , sboostRandomItem = False+  , sgameMode = Nothing+  , sautomateAll = False+  , skeepAutomated = False+  , sdungeonRng = Nothing+  , smainRng = Nothing+  , snewGameSer = False+  , scurChalSer = defaultChallenge+  , sdumpInitRngs = False+  , ssavePrefixSer = ""+  , sdbgMsgSer = False+  , sassertExplored = Nothing+  , sshowItemSamples = False+  , sstopAfterGameOver = False+  , sclientOptions = defClientOptions+  }
+ engine-src/Game/LambdaHack/Server/StartM.hs view
@@ -0,0 +1,456 @@+-- | Operations for starting and restarting the game.+module Game.LambdaHack.Server.StartM+  ( initPer, reinitGame, gameReset, applyDebug+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , sampleTrunks, sampleItems+  , mapFromFuns, resetFactions, populateDungeon, findEntryPoss+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Monad.Trans.State.Strict as St+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import           Data.Key (mapWithKeyM_)+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU+import qualified System.Random.SplitMix32 as SM++import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Analytics+import           Game.LambdaHack.Common.Area+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Types+import qualified Game.LambdaHack.Content.CaveKind as CK+import           Game.LambdaHack.Content.FactionKind+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import           Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Core.Dice as Dice+import           Game.LambdaHack.Core.Frequency+import           Game.LambdaHack.Core.Random+import qualified Game.LambdaHack.Definition.Ability as Ability+import qualified Game.LambdaHack.Definition.Color as Color+import           Game.LambdaHack.Definition.Defs+import           Game.LambdaHack.Definition.Flavour+import           Game.LambdaHack.Server.CommonM+import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen+import           Game.LambdaHack.Server.Fov+import           Game.LambdaHack.Server.ItemM+import           Game.LambdaHack.Server.ItemRev+import           Game.LambdaHack.Server.MonadServer+import           Game.LambdaHack.Server.ServerOptions+import           Game.LambdaHack.Server.State++initPer :: MonadServer m => m ()+initPer = do+  ( sfovLitLid, sfovClearLid, sfovLucidLid+   ,sperValidFid, sperCacheFid, sperFid ) <- getsState perFidInDungeon+  modifyServer $ \ser ->+    ser { sfovLitLid, sfovClearLid, sfovLucidLid+        , sperValidFid, sperCacheFid, sperFid }++reinitGame :: MonadServerAtomic m => FactionDict -> m ()+reinitGame factionDold = do+  COps{coitem} <- getsState scops+  pers <- getsServer sperFid+  ServerOptions{scurChalSer, sknowMap, sshowItemSamples, sclientOptions}+    <- getsServer soptions+  -- This state is quite small, fit for transmition to the client.+  -- The biggest part is content, which needs to be updated in clients+  -- at this point to keep them in sync with changes on the server.+  s <- getState+  discoS <- getsState sdiscoKind+  -- Thanks to the following, for any item with not hidden identity,+  -- the client has its kind from the start. The client needs to know this+  -- to have a fast way (faster that looking for @PresentAs@ flag on a list)+  -- of determining whether an item kind is already identified+  -- or needs identification.+  let discoKindFiltered =+        let f kindId = isNothing $ IK.getMandatoryPresentAsFromKind+                                 $ okind coitem kindId+        in EM.filter f discoS+      defL | sknowMap = s+           | otherwise = localFromGlobal s+      defLocal = updateDiscoKind (const discoKindFiltered) defL+  factionD <- getsState sfactionD+  clientStatesOld <- getsServer sclientStates+  metaBackupOld <- getsServer smetaBackup+  -- Some item kinds preserve their identity and flavour throughout+  -- the whole meta-game, until the savefiles are removed.+  -- These are usually not common man-made items, because these can be made+  -- in many flavours so it may be hard to recognize them.+  -- Character backstories and rare artifacts are uncommon enough+  -- to requiring learning their identify only once.+  -- However, the exact properties of even natural items may vary,+  -- so the random aspects of items, stored in @sdiscoAspect@+  -- are not preserved (a lot of other state components would need+  -- to be partially preserved, too, both on server and clients).+  let inMetaGame kindId = IK.SetFlag Ability.MetaGame+                          `elem` IK.iaspects (okind coitem kindId)+      metaDiscoOldFid =+        EM.map (EM.filter inMetaGame . sdiscoKind) clientStatesOld+      fidToTeam :: FactionId -> TeamContinuity+      fidToTeam fid = fteam $ gkind $ factionDold EM.! fid+      metaDiscoOldTeam =+        EM.fromList $ map (first fidToTeam) $ EM.assocs metaDiscoOldFid+      exclusiveUnion = EM.unionWith $ \_ _ -> error "forbidden duplicate"+      metaDiscoAll = metaDiscoOldTeam `exclusiveUnion` metaBackupOld+      currentTeams = ES.fromList $ map (fteam . gkind) $ EM.elems factionD+      metaBackupNew = EM.withoutKeys metaDiscoAll currentTeams+      stateNew fact = case EM.lookup (fteam $ gkind fact) metaDiscoAll of+        Nothing -> defLocal+        Just disco -> updateDiscoKind (disco `EM.union`) defLocal+      clientStatesNew = EM.map stateNew factionD+  modifyServer $ \ser -> ser { sclientStates = clientStatesNew+                             , smetaBackup = metaBackupNew }+  let updRestart fid = UpdRestart fid (pers EM.! fid) (clientStatesNew EM.! fid)+                                  scurChalSer sclientOptions+  mapWithKeyM_ (\fid _ -> do+    -- Different seed for each client, to make sure behaviour is varied.+    gen1 <- getsServer srandom+    let (clientRandomSeed, gen2) = SM.splitSMGen gen1+    modifyServer $ \ser -> ser {srandom = gen2}+    execUpdAtomic $ updRestart fid clientRandomSeed) factionD+  dungeon <- getsState sdungeon+  let sactorTime = EM.map (const (EM.map (const EM.empty) dungeon)) factionD+      strajTime = EM.map (const (EM.map (const EM.empty) dungeon)) factionD+  modifyServer $ \ser -> ser {sactorTime, strajTime}+  when sshowItemSamples $ do+    genOrig <- getsServer srandom+    uniqueSetOrig <- getsServer suniqueSet+    genOld <- getsServer sgenerationAn+    genSampleTrunks <- sampleTrunks dungeon+    genSampleItems <- sampleItems dungeon+    let sgenerationAn = EM.unions [genSampleTrunks, genSampleItems, genOld]+    modifyServer $ \ser -> ser {sgenerationAn}+    -- Make sure the debug generations don't affect future RNG behaviour.+    -- However, in the long run, AI behaviour is affected anyway,+    -- because the items randomly chosen for AI actions are ordered by their+    -- @ItemId@, which is affected by the sample item generation.+    modifyServer $ \ser -> ser {srandom = genOrig, suniqueSet = uniqueSetOrig}+  populateDungeon+  mapM_ (\fid -> mapM_ (updatePer fid) (EM.keys dungeon))+        (EM.keys factionD)++-- For simplicity only spawnable actors are taken into account, not starting+-- actors of any faction nor summonable actors.+sampleTrunks :: MonadServerAtomic m => Dungeon -> m GenerationAnalytics+sampleTrunks dungeon = do+  COps{cocave, coitem} <- getsState scops+  factionD <- getsState sfactionD+  let getGroups Level{lkind} = map fst $ CK.cactorFreq $ okind cocave lkind+      groups = S.elems $ S.fromList $ concatMap getGroups $ EM.elems dungeon+      addGroupToSet !s0 !grp =+        ofoldlGroup' coitem grp (\s _ ik _ -> ES.insert ik s) s0+      trunkKindIds = ES.elems $ foldl' addGroupToSet ES.empty groups+      minLid = fst $ minimumBy (comparing (ldepth . snd))+                   $ EM.assocs dungeon+  Level{ldepth} <- getLevel minLid+  let regItem itemKindId = do+        let itemKind = okind coitem itemKindId+            freq = pure (IK.HORROR, itemKindId, itemKind)+        case runFrequency $ possibleActorFactions [] itemKind factionD of+          [] -> error "sampleTrunks: null faction frequency"+          (_, (fid, _)) : _ -> do+            let c = CTrunk fid minLid originPoint+                jfid = Just fid+            m2 <- rollItemAspect freq ldepth+            case m2 of+              NoNewItem -> error "sampleTrunks: can't create actor trunk"+              NewItem _ (ItemKnown kindIx ar _) itemFullRaw itemQuant -> do+                let itemKnown = ItemKnown kindIx ar jfid+                    itemFull =+                      itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}}+                Just <$> registerItem False (itemFull, itemQuant) itemKnown c+  miids <- mapM regItem trunkKindIds+  return $! EM.singleton STrunk+            $ EM.fromDistinctAscList $ zip (catMaybes miids) $ repeat 0++-- For simplicity, only actors generated on the ground are taken into account.+-- not starting items of any actors nor items that can be create by effects+-- occuring in the game.+sampleItems :: MonadServerAtomic m => Dungeon -> m GenerationAnalytics+sampleItems dungeon = do+  COps{cocave, coitem} <- getsState scops+  let getGroups Level{lkind} = map fst $ CK.citemFreq $ okind cocave lkind+      groups = S.elems $ S.fromList $ concatMap getGroups $ EM.elems dungeon+      addGroupToSet !s0 !grp =+        ofoldlGroup' coitem grp (\s _ ik _ -> ES.insert ik s) s0+      itemKindIds = ES.elems $ foldl' addGroupToSet ES.empty groups+      minLid = fst $ minimumBy (comparing (ldepth . snd))+                   $ EM.assocs dungeon+  Level{ldepth} <- getLevel minLid+  let regItem itemKindId = do+        let itemKind = okind coitem itemKindId+            freq = pure (IK.HORROR, itemKindId, itemKind)+            c = CFloor minLid originPoint+        m2 <- rollItemAspect freq ldepth+        case m2 of+          NoNewItem -> error "sampleItems: can't create sample item"+          NewItem _ itemKnown itemFull _ ->+            Just <$> registerItem False (itemFull, (0, [])) itemKnown c+  miids <- mapM regItem itemKindIds+  return $! EM.singleton SItem+            $ EM.fromDistinctAscList $ zip (catMaybes miids) $ repeat 0++mapFromFuns :: Ord b => [a] -> [a -> b] -> M.Map b a+mapFromFuns domain =+  let fromFun f m1 =+        let invAssocs = map (\c -> (f c, c)) domain+            m2 = M.fromList invAssocs+        in m2 `M.union` m1+  in foldr fromFun M.empty++resetFactions :: ContentData FactionKind -> Dice.AbsDepth -> ModeKind -> Bool+              -> Rnd FactionDict+resetFactions cofact totalDepth mode+              automateAll = do+  let rawCreate (fid, (fkGroup, initialActors)) = do+        -- Validation of content guarantess the existence of such faction kind.+        gkindId <- fromJust <$> opick cofact fkGroup (const True)+        let gkind@FactionKind{..} = okind cofact gkindId+            castInitialActors (ln, d, actorGroup) = do+              n <- castDice (Dice.AbsDepth $ abs ln) totalDepth d+              return (ln, n, actorGroup)+        ginitial <- mapM castInitialActors initialActors+        let cmap =+              mapFromFuns Color.legalFgCol+                          [colorToTeamName, colorToPlainName, colorToFancyName]+            colorName = T.toLower $ head $ T.words fname+            prefix = case (fhasPointman, finitUnderAI) of+              (False, False) -> "Uncoordinated"+              (False, True) -> "Loose"+              (True, False) -> "Autonomous"+              (True, True) -> "Controlled"+            gnameNew = prefix <+> if fhasGender+                                  then makePhrase [MU.Ws $ MU.Text fname]+                                  else fname+            gcolor = M.findWithDefault Color.BrWhite colorName cmap+        let gname = gnameNew+            gdoctrine = finitDoctrine+            gunderAI = finitUnderAI || mattract mode || automateAll+            gdipl = EM.empty  -- fixed below+            gquit = Nothing+            _gleader = Nothing+            gvictims = EM.empty+            gstash = Nothing+        return (fid, Faction{..})+  lFs <- mapM rawCreate $ zip [toEnum 1 ..] $ mroster mode+  let mkDipl diplMode =+        let f (ix1, ix2) =+              let adj1 fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)}+              in EM.adjust adj1 ix1+        in foldr f+      -- Only symmetry is ensured, everything else is permitted,+      -- e.g., a faction in alliance with two others that are at war.+      pairsFromFaction :: (FactionKind -> [TeamContinuity])+                       -> (FactionId, Faction)+                       -> [(FactionId, FactionId)]+      pairsFromFaction selector (fid, fact) =+        let teams = selector $ gkind fact+            hasTeam team (_, fact2) = team == fteam (gkind fact2)+            pairsFromTeam team = case find (hasTeam team) lFs of+              Just (fid2, _) -> [(fid, fid2), (fid2, fid)]+              Nothing -> []+        in concatMap pairsFromTeam teams+      rawFs = EM.fromList lFs+      -- War overrides alliance, so 'warFs' second. Consequently, if a faction+      -- is allied with a faction that is at war with them, they will be+      -- symmetrically at war.+      allianceFs = mkDipl Alliance rawFs+                   $ concatMap (pairsFromFaction falliedTeams) $ EM.assocs rawFs+      warFs = mkDipl War allianceFs+              $ concatMap (pairsFromFaction fenemyTeams) $ EM.assocs allianceFs+  return $! warFs++gameReset :: MonadServer m+          => ServerOptions -> Maybe (GroupName ModeKind)+          -> Maybe SM.SMGen -> m State+gameReset serverOptions mGameMode mrandom = do+  -- Dungeon seed generation has to come first, to ensure item boosting+  -- is determined by the dungeon RNG.+  cops@COps{cofact, comode} <- getsState scops+  dungeonSeed <- getSetGen $ sdungeonRng serverOptions `mplus` mrandom+  srandom <- getSetGen $ smainRng serverOptions `mplus` mrandom+  let srngs = RNGs (Just dungeonSeed) (Just srandom)+  when (sdumpInitRngs serverOptions) $ dumpRngs srngs+  scoreTable <- restoreScore cops+  teamGearOld <- getsServer steamGear+  flavourOld <- getsServer sflavour+  discoKindRevOld <- getsServer sdiscoKindRev+  clientStatesOld <- getsServer sclientStates+  let gameMode = fromMaybe INSERT_COIN+                 $ mGameMode `mplus` sgameMode serverOptions+      rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev,+                  DungeonGen.FreshDungeon, ContentId ModeKind)+      rnd = do+        modeKindId <-+          fromMaybe (error $ "Unknown game mode:" `showFailure` gameMode)+          <$> opick comode gameMode (const True)+        let mode = okind comode modeKindId+        flavour <- dungeonFlavourMap cops flavourOld+        (discoKind, sdiscoKindRev) <- serverDiscos cops discoKindRevOld+        freshDng <- DungeonGen.dungeonGen cops serverOptions $ mcaves mode+        factionD <- resetFactions cofact (DungeonGen.freshTotalDepth freshDng)+                                  mode (sautomateAll serverOptions)+        return ( factionD, flavour, discoKind+               , sdiscoKindRev, freshDng, modeKindId )+  let ( factionD, sflavour, discoKind+       ,sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId ) =+        St.evalState rnd dungeonSeed+      defState = defStateGlobal freshDungeon freshTotalDepth+                                factionD cops scoreTable modeKindId discoKind+      defSer = emptyStateServer { srandom+                                , srngs }+  putServer defSer+  modifyServer $ \ser -> ser { steamGear = teamGearOld+                             , steamGearCur = teamGearOld+                             , sclientStates = clientStatesOld  -- reset later+                             , sdiscoKindRev+                             , sflavour }+  return $! defState++-- Spawn initial actors. Clients should notice this, to set their leaders.+populateDungeon :: forall m. MonadServerAtomic m => m ()+populateDungeon = do+  cops@COps{coTileSpeedup} <- getsState scops+  factionD <- getsState sfactionD+  curChalSer <- getsServer $ scurChalSer . soptions+  let nGt0 (_, n, _) = n > 0+      ginitialWolf fact1 = if cwolf curChalSer && fhasUI (gkind fact1)+                           then case filter nGt0 $ ginitial fact1 of+                             [] -> []+                             (ln, _, grp) : _ -> [(ln, 1, grp)]+                           else ginitial fact1+      -- Keep the same order of factions as in roster.+      needInitialCrew = sortBy (comparing fst)+                        $ filter (not . null . ginitialWolf . snd)+                        $ EM.assocs factionD+      getEntryLevels (_, fact) =+        map (\(ln, _, _) -> toEnum ln) $ ginitialWolf fact+      arenas = ES.elems $ ES.fromList $ concatMap getEntryLevels needInitialCrew+      hasActorsOnArena lid (_, fact) =+        any (\(ln, _, _) -> toEnum ln == lid) $ ginitialWolf fact+      initialActorPositions :: LevelId+                            -> m (LevelId, EM.EnumMap FactionId Point)+      initialActorPositions lid = do+        lvl <- getLevel lid+        let arenaFactions =+              map fst $ filter (hasActorsOnArena lid) needInitialCrew+        entryPoss <- rndToAction $ findEntryPoss cops lvl (length arenaFactions)+        when (length entryPoss < length arenaFactions) $ debugPossiblyPrint+          "Server: populateDungeon: failed to find enough distinct faction starting positions; some factions share positions"+        let usedPoss = EM.fromList $ zip arenaFactions $ cycle entryPoss+        return (lid, usedPoss)+  factionPositions <- EM.fromDistinctAscList+                      <$> mapM initialActorPositions arenas+  let initialActors :: (FactionId, Faction) -> m ()+      initialActors (fid3, fact3) =+        mapM_ (placeActors fid3) $ ginitialWolf fact3+      placeActors :: FactionId -> (Int, Int, GroupName ItemKind) -> m ()+      placeActors fid3 (ln, n, actorGroup) = do+        let lid = toEnum ln+        lvl <- getLevel lid+        let ppos = factionPositions EM.! lid EM.! fid3+            validTile t = not $ Tile.isNoActor coTileSpeedup t+            -- This takes into account already spawned actors of this+            -- and other factions. If not enough space, some are skipped.+            psFree = nearbyFreePoints cops lvl validTile ppos+            ps = take n psFree+        when (length ps < n) $ debugPossiblyPrint+          "Server: populateDungeon: failed to find enough initial actor positions; some actors are not generated"+        localTime <- getsState $ getLocalTime lid+        forM_ ps $ \p -> do+          rndDelay <- rndToAction $ randomR (1, clipsInTurn - 1)+          let delta = timeDeltaScale (Delta timeClip) rndDelay+              rndTime = timeShift localTime delta+          maid <- addActorFromGroup actorGroup fid3 p lid rndTime+          case maid of+            Nothing -> error $ "can't spawn initial actors"+                               `showFailure` (lid, fid3)+            Just aid -> do+              mleader <- getsState $ gleader . (EM.! fid3) . sfactionD+              -- Sleeping actor may become a leader, but it's quickly corrected.+              when (isNothing mleader) $ setFreshLeader fid3 aid+  placeItemsInDungeon factionPositions+  embedItemsInDungeon+  mapM_ initialActors needInitialCrew++-- | Find starting postions for all factions. Try to make them distant+-- from each other. Place as many of the factions, as possible,+-- over stairs. Place the first faction(s) over escape(s)+-- (we assume they are guardians of the escapes).+-- This implies the inital factions (if any) start far from escapes.+findEntryPoss :: COps -> Level -> Int -> Rnd [Point]+findEntryPoss COps{cocave, coTileSpeedup}+              lvl@Level{lkind, larea, lstair, lescape}+              kRaw = do+  let lskip = CK.cskip $ okind cocave lkind+      k = kRaw + length lskip  -- if @lskip@ is bogus, will be too large; OK+      (_, xspan, yspan) = spanArea larea+      factionDist = max xspan yspan - 10+      dist !poss !cmin !l _ = all (\ !pos -> chessDist l pos > cmin) poss+      tryFind _ 0 = return []+      tryFind !ps !n = do+        let ds = [ dist ps factionDist+                 , dist ps $ factionDist `div` 2+                 , dist ps $ factionDist `div` 3+                 , dist ps $ max 5 $ factionDist `div` 5+                 , dist ps $ max 2 $ factionDist `div` 10+                 ]+        mp <- findPosTry2 500 lvl  -- try really hard, for skirmish fairness+                (\_ !t -> Tile.isWalkable coTileSpeedup t+                          && not (Tile.isNoActor coTileSpeedup t))+                (take 2 ds)  -- don't pick too close @isOftenActor@ locations+                (\_ !t -> Tile.isOftenActor coTileSpeedup t)+                ds+        case mp of+          Just np -> do+            nps <- tryFind (np : ps) (n - 1)+            return $! np : nps+          Nothing -> return []+      sameStaircase :: [Point] -> Point -> Bool+      sameStaircase upStairs Point{..} =+        any (\(Point ux uy) -> uy == py && ux + 2 == px) upStairs+      upAndSomeDownStairs =+        fst lstair+        ++ filter (not . sameStaircase (fst lstair)) (snd lstair)+      skipIndexes ixs l = map snd $ filter (\(ix, _) -> ix `notElem` ixs)+                                  $ zip [0..] l+  let !_A = assert (k > 0 && factionDist > 0) ()+      onEscapes = take k lescape+      onStairs = take (k - length onEscapes) upAndSomeDownStairs+      nk = k - length onEscapes - length onStairs+  -- Starting in the middle is too easy.+  found <- tryFind (middlePoint larea : onEscapes ++ onStairs) nk+  return $! skipIndexes lskip $ onEscapes ++ onStairs ++ found++-- | Apply options that don't need a new game.+applyDebug :: MonadServer m => m ()+applyDebug = do+  ServerOptions{..} <- getsServer soptionsNxt+  modifyServer $ \ser ->+    ser {soptions = (soptions ser) { sniff+                                   , sallClear+                                   , sdbgMsgSer+                                   , snewGameSer+                                   , sassertExplored+                                   , sdumpInitRngs+                                   , sclientOptions }}
+ engine-src/Game/LambdaHack/Server/State.hs view
@@ -0,0 +1,227 @@+-- | Server and client game state types and operations.+module Game.LambdaHack.Server.State+  ( StateServer(..), ActorTime, ActorPushedBy+  , emptyStateServer, updateActorTime, lookupActorTime, ageActor+#ifdef EXPOSE_INTERNAL+  , GearOfTeams+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap.Strict as IM+import qualified System.Random.SplitMix32 as SM++import Game.LambdaHack.Common.Analytics+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Types+import Game.LambdaHack.Content.FactionKind (TeamContinuity)+import Game.LambdaHack.Content.ItemKind (ItemKind)+import Game.LambdaHack.Definition.Defs+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.ItemRev+import Game.LambdaHack.Server.ServerOptions++-- | State with server-specific data, including a copy of each client's+-- basic game state, but not the server's basic state.+data StateServer = StateServer+  { sactorTime    :: ActorTime      -- ^ absolute times of actors next actions+  , strajTime     :: ActorTime      -- ^ and same for actors with trajectories+  , strajPushedBy :: ActorPushedBy  -- ^ culprits for actors with trajectories+  , steamGear     :: GearOfTeams    -- ^ metagame persistent personal+                                    --   characteristics and favourite gear+                                    --   of each numbered continued team member+  , steamGearCur  :: GearOfTeams    -- ^ gear preferences to be taken into+                                    --   account in the current game+  , stcounter     :: EM.EnumMap TeamContinuity Int+                                    -- ^ stores next continued team character+                                    --   identity index number in this game+  , sfactionAn    :: FactionAnalytics+                                    -- ^ various past events data for factions+  , sactorAn      :: ActorAnalytics -- ^ various past events data for actors+  , sgenerationAn :: GenerationAnalytics+                                    -- ^ item creation statistics, by item lore+  , sactorStasis  :: ES.EnumSet ActorId+                                    -- ^ actors currently in time stasis,+                                    --   invulnerable to time warps until move+  , sdiscoKindRev :: DiscoveryKindRev+                                    -- ^ reverse map, used for item creation+  , suniqueSet    :: UniqueSet      -- ^ already generated unique items+  , sitemRev      :: ItemRev        -- ^ reverse id map, used for item creation+  , sflavour      :: FlavourMap     -- ^ association of flavour to item kinds+  , sacounter     :: ActorId        -- ^ stores next actor index+  , sicounter     :: ItemId         -- ^ stores next item index+  , snumSpawned   :: EM.EnumMap LevelId Int+                                    -- ^ how many spawned so far on the level+  , sbandSpawned  :: IM.IntMap Int  -- ^ how many times such group spawned+  , sundo         :: () -- [CmdAtomic] -- ^ atomic commands performed to date+  , sclientStates :: EM.EnumMap FactionId State+                                    -- ^ each faction state, as seen by clients+  , smetaBackup   :: EM.EnumMap TeamContinuity DiscoveryKind+                                    -- ^ discovery info for absent factions+  , sperFid       :: PerFid         -- ^ perception of all factions+  , sperValidFid  :: PerValidFid    -- ^ perception validity for all factions+  , sperCacheFid  :: PerCacheFid    -- ^ perception cache of all factions+  , sfovLucidLid  :: FovLucidLid    -- ^ ambient or shining light positions+  , sfovClearLid  :: FovClearLid    -- ^ clear tiles positions+  , sfovLitLid    :: FovLitLid      -- ^ ambient light positions+  , sarenas       :: ES.EnumSet LevelId+                                    -- ^ the set of active arenas+  , svalidArenas  :: Bool           -- ^ whether active arenas valid+  , srandom       :: SM.SMGen       -- ^ current random generator+  , srngs         :: RNGs           -- ^ initial random generators+  , sbreakLoop    :: Bool           -- ^ exit game loop after clip's end;+                                    --   usually no game save follows+  , sbreakASAP    :: Bool           -- ^ exit game loop ASAP; usually with save+  , swriteSave    :: Bool           -- ^ write savegame to file after loop exit+  , soptions      :: ServerOptions  -- ^ current commandline options+  , soptionsNxt   :: ServerOptions  -- ^ options for the next game+  }+  deriving Show++-- | Position in time for each actor, grouped by level and by faction.+type ActorTime =+  EM.EnumMap FactionId (EM.EnumMap LevelId (EM.EnumMap ActorId Time))++-- | Record who last propelled a given actor with trajectory.+type ActorPushedBy = EM.EnumMap ActorId ActorId++-- | Per-team, per-actor metagame persistent favourite organs and gear.+type GearOfTeams = EM.EnumMap+                     TeamContinuity+                     (IM.IntMap [(GroupName ItemKind, ContentId ItemKind)])++-- | Initial, empty game server state.+emptyStateServer :: StateServer+emptyStateServer =+  StateServer+    { sactorTime = EM.empty+    , strajTime = EM.empty+    , strajPushedBy = EM.empty+    , steamGear = EM.empty+    , steamGearCur = EM.empty+    , stcounter = EM.empty+    , sfactionAn = EM.empty+    , sactorAn = EM.empty+    , sgenerationAn = EM.fromDistinctAscList+                      $ zip [minBound..maxBound] (repeat EM.empty)+    , sactorStasis = ES.empty+    , sdiscoKindRev = emptyDiscoveryKindRev+    , suniqueSet = ES.empty+    , sitemRev = HM.empty+    , sflavour = emptyFlavourMap+    , sacounter = toEnum 0+    , sicounter = toEnum 0+    , snumSpawned = EM.empty+    , sbandSpawned = IM.fromList [(1, 0), (2, 0), (3, 0)]+    , sundo = ()+    , sclientStates = EM.empty+    , smetaBackup = EM.empty+    , sperFid = EM.empty+    , sperValidFid = EM.empty+    , sperCacheFid = EM.empty+    , sfovLucidLid = EM.empty+    , sfovClearLid = EM.empty+    , sfovLitLid = EM.empty+    , sarenas = ES.empty+    , svalidArenas = False+    , srandom = SM.mkSMGen 42+    , srngs = RNGs { dungeonRandomGenerator = Nothing+                   , startingRandomGenerator = Nothing }+    , sbreakLoop = False+    , sbreakASAP = False+    , swriteSave = False+    , soptions = defServerOptions+    , soptionsNxt = defServerOptions+    }++updateActorTime :: FactionId -> LevelId -> ActorId -> Time -> ActorTime+                -> ActorTime+updateActorTime !fid !lid !aid !time =+  EM.adjust (EM.adjust (EM.insert aid time) lid) fid++lookupActorTime :: FactionId -> LevelId -> ActorId -> ActorTime+                -> Maybe Time+lookupActorTime !fid !lid !aid !atime = do+  m1 <- EM.lookup fid atime+  m2 <- EM.lookup lid m1+  EM.lookup aid m2++ageActor :: FactionId -> LevelId -> ActorId -> Delta Time -> ActorTime+         -> ActorTime+ageActor !fid !lid !aid !delta =+  EM.adjust (EM.adjust (EM.adjust (`timeShift` delta) aid) lid) fid++instance Binary StateServer where+  put StateServer{..} = do+    put sactorTime+    put strajTime+    put strajPushedBy+    put steamGear+    put steamGearCur+    put stcounter+    put sfactionAn+    put sactorAn+    put sgenerationAn+    put sactorStasis+    put sdiscoKindRev+    put suniqueSet+    put sitemRev+    put sflavour+    put sacounter+    put sicounter+    put snumSpawned+    put sbandSpawned+    put sclientStates+    put smetaBackup+    put (show srandom)+    put srngs+    put soptions+  get = do+    sactorTime <- get+    strajTime <- get+    strajPushedBy <- get+    steamGear <- get+    steamGearCur <- get+    stcounter <- get+    sfactionAn <- get+    sactorAn <- get+    sgenerationAn <- get+    sactorStasis <- get+    sdiscoKindRev <- get+    suniqueSet <- get+    sitemRev <- get+    sflavour <- get+    sacounter <- get+    sicounter <- get+    snumSpawned <- get+    sbandSpawned <- get+    sclientStates <- get+    smetaBackup <- get+    g <- get+    srngs <- get+    soptions <- get+    let srandom = read g+        sundo = ()+        sperFid = EM.empty+        sperValidFid = EM.empty+        sperCacheFid = EM.empty+        sfovLucidLid = EM.empty+        sfovClearLid = EM.empty+        sfovLitLid = EM.empty+        sarenas = ES.empty+        svalidArenas = False+        sbreakLoop = False+        sbreakASAP = False+        swriteSave = False+        soptionsNxt = defServerOptions+    return $! StateServer{..}
+ test/ActorStateUnitTests.hs view
@@ -0,0 +1,25 @@+module ActorStateUnitTests (actorStateUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Test.Tasty+import Test.Tasty.HUnit++import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Definition.Ability as Ability++import UnitTestHelpers++actorStateUnitTests :: TestTree+actorStateUnitTests = testGroup "actorStateUnitTests"+  [ testCase "getActorBody verify stubCliState has testActor" $+      getActorBody testActorId (cliState stubCliState) @?= testActor+  , testCase "getActorMaxSkills verify stubCliState has zeroSkills" $+      getActorMaxSkills testActorId (cliState stubCliState)+      @?= Ability.zeroSkills+  , testCase "fidActorNotProjGlobalAssocs" $+      fidActorNotProjGlobalAssocs testFactionId (cliState testCliStateWithItem)+      @?= [(testActorId, testActorWithItem)]+  ]
+ test/CommonMUnitTests.hs view
@@ -0,0 +1,27 @@+module CommonMUnitTests (commonMUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Test.Tasty+import Test.Tasty.HUnit++import Game.LambdaHack.Client.CommonM+import Game.LambdaHack.Common.Kind (emptyCOps)+import Game.LambdaHack.Common.Perception (emptyPer)+import Game.LambdaHack.Common.Point (Point (..))++import UnitTestHelpers+  (executorCli, stubCliState, testActor, testLevel, testLevelId)++commonMUnitTests :: TestTree+commonMUnitTests = testGroup "commonMUnitTests"+  [ testCase "getPerFid stubCliState returns emptyPerception" $ do+      result <- executorCli (getPerFid testLevelId) stubCliState+      fst result @?= emptyPer+  , testCase "makeLine, when actor stands at the target position, fails" $+      Nothing @?= makeLine False testActor (Point 0 0) 1 emptyCOps testLevel+  , testCase "makeLine unknownTiles succeeds" $+      Just 1 @?= makeLine False testActor (Point 2 0) 1 emptyCOps testLevel+  ]
+ test/HandleHelperMUnitTests.hs view
@@ -0,0 +1,22 @@+module HandleHelperMUnitTests (handleHelperMUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Test.Tasty+import Test.Tasty.HUnit++import Game.LambdaHack.Client.UI.HandleHelperM++import UnitTestHelpers++handleHelperMUnitTests :: TestTree+handleHelperMUnitTests = testGroup "handleHelperMUnitTests"+  [ testCase "partyAfterLeader" $ do+      -- You've got to fight for your right to party!+      let testFunc = partyAfterLeader testActorId+      partyInMonad <- executorCli testFunc testCliStateWithItem+      let party = fst partyInMonad+      party @?= []+  ]
+ test/HandleHumanLocalMUnitTests.hs view
@@ -0,0 +1,99 @@+module HandleHumanLocalMUnitTests (handleHumanLocalMUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T++import Test.Tasty+import Test.Tasty.HUnit++import           Game.LambdaHack.Client.UI (SessionUI (..), modifySession)+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.HandleHumanLocalM+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.TutorialHints+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.ItemAspect+import           Game.LambdaHack.Common.Kind (emptyMultiGroupItem)+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.PointArray as PointArray+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Content.TileKind+import           Game.LambdaHack.Definition.DefsInternal+  (toContentId, toContentSymbol)++import UnitTestHelpers++testItemFull :: ItemFull+testItemFull = ItemFull { itemBase = stubItem, itemKindId = toContentId 0, itemKind = emptyMultiGroupItem, itemDisco = ItemDiscoFull emptyAspectRecord, itemSuspect = False }++handleHumanLocalMUnitTests :: TestTree+handleHumanLocalMUnitTests = testGroup "handleHumanLocalMUnitTests"+  [ testCase "verify stubLevel has tile element" $+      case EM.lookup testLevelId (sdungeon stubState) of+        Nothing -> assertFailure "stubLevel lost in dungeon"+        Just level -> ltile level ! Point 0 0 @?= unknownId+  , testCase "verify stubCliState has actor" $+      getActorBody testActorId (cliState stubCliState) @?= testActor+  , testCase "permittedProjectClient stubCliState returns ProjectUnskilled" $ do+      let testFn = permittedProjectClient testActorId+      permittedProjectClientResultFnInMonad <- executorCli testFn stubCliState+      let ultimateResult =+            fst permittedProjectClientResultFnInMonad testItemFull+      ultimateResult @?= Left ProjectUnskilled+  , testCase "chooseItemProjectHuman" $ do+      let testFn = let triggerItems =+                         [ HumanCmd.TriggerItem {tiverb = "verb", tiobject = "object", tisymbols = [toContentSymbol 'a', toContentSymbol 'b']}+                         , HumanCmd.TriggerItem {tiverb = "verb2", tiobject = "object2", tisymbols = [toContentSymbol 'c']}+                         ]+                   in chooseItemProjectHuman testActorId triggerItems+      result <- executorCli testFn testCliStateWithItem+      showFailError (fromJust (fst result)) @?= "*aiming obstructed by terrain*"+  , testCase "tutorialHints-msg-in-history-report" $ do+      let testFn = do+            modifySession (\sess -> sess {scurTutorial = True})+              -- permit the client not to ignore tutorial hints+            tutorialHintMsgAdd CannotHarmYouInMelee+      result <- executorCli testFn testCliStateWithItem+      let maybeHistory = shistory <$> (cliSession . snd) result+      case maybeHistory of+        Nothing -> assertFailure "History is empty"+        Just history -> assertBool testFailureMsg isHintThere+         where+          renderedNewReports = reportToTexts . newReport $ history+          renderedHint = renderTutorialHints CannotHarmYouInMelee+          isHintThere = renderedHint `elem` renderedNewReports+          testFailureMsg = "Expected to find tutorial hint '"+            <> (T.unpack . renderTutorialHints $ CannotHarmYouInMelee)+            <> "' in SessionUI.shistory.newReport '"+            <> T.unpack (T.unlines renderedNewReports)+            <> "'"+  , testCase "psuitReq" $  do+      let testFn = psuitReq testActorId+      mpsuitReqMonad <- executorCli testFn testCliStateWithItem+      let mpsuitReq = fst mpsuitReqMonad+      case mpsuitReq of+        Left err -> do+          err @?= "aiming obstructed by terrain"+            -- TODO: I'd split the test into three tests, each taking a different branch and fail in the remaining two branches that the particular branch doesn't take. Here it takes the first branch, because unknown tiles are not walkable (regardless what I claimed previously) and so the player is surrounded by walls, basically, so aiming fails, because the projectiles wouldn't even leave the position of the actor. I think.+        Right psuitReqFun ->+          case psuitReqFun testItemFull of+            Left reqFail -> do+              reqFail @?= ProjectUnskilled+            Right (pos, _) -> do+              pos @?= Point 0 0+  , testCase "xhairLegalEps" $ do+      let testFn = xhairLegalEps testActorId+      result <- executorCli testFn testCliStateWithItem+      fst result @?= Right 114  -- not a coincidence this matches testFactionId,+                                -- because @eps@ is initialized that way,+                                -- for "randomness"+  ]
+ test/InventoryMUnitTests.hs view
@@ -0,0 +1,49 @@+-- TODO: at some point we'll want our unit test hierarchy to match the+-- main codebase file hierarchy+module InventoryMUnitTests (inventoryMUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Test.Tasty+import Test.Tasty.HUnit++import Game.LambdaHack.Client.UI.InventoryM+import Game.LambdaHack.Definition.Defs++import UnitTestHelpers++inventoryMUnitTests :: TestTree+inventoryMUnitTests = testGroup "inventoryMUnitTests"+  [ testCase "getFull no stores " $ do+      let testFn = getFull testActorId+                           (return SuitsEverything)  -- :: m Suitability+                           (\_ _ _ _ _ -> "specific prompt")+                           (\_ _ _ _ _ -> "generic prompt")+                           []  -- :: [CStore]+                           False+                           False+      result <- executorCli testFn stubCliState+      fst result @?= Left "no items"+  , testCase "getFull no item in eqp store" $ do+      let testFn = getFull testActorId+                           (return SuitsEverything)+                           (\_ _ _ _ _ -> "specific prompt")+                           (\_ _ _ _ _ -> "generic prompt")+                           [CEqp]+                           False+                           False+      result <- executorCli testFn stubCliState+      fst result @?= Left "no items in equipment outfit"+  , testCase "getFull an item in eqp store" $ do+      let testFn = getFull testActorId+                           (return SuitsEverything)+                           (\_ _ _ _ _ -> "specific prompt")+                           (\_ _ _ _ _ -> "generic prompt")+                           [CEqp]+                           False+                           False+      result <- executorCli testFn testCliStateWithItem+      fst result @?= Right (CEqp, [(testItemId, (1, []))])+  ]
+ test/ItemDescriptionUnitTests.hs view
@@ -0,0 +1,48 @@+module ItemDescriptionUnitTests (itemDescriptionUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import           Test.Tasty+import           Test.Tasty.HUnit++import Game.LambdaHack.Client.UI.ItemDescription+  (viewItem, viewItemBenefitColored)+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemAspect (emptyAspectRecord)+import Game.LambdaHack.Common.Kind (emptyMultiGroupItem)+import Game.LambdaHack.Content.ItemKind (ItemKind (isymbol))+import Game.LambdaHack.Definition.Color+  (Color (BrGreen, BrRed, Green), attrChar2ToW32)+import Game.LambdaHack.Definition.Flavour (zipPlain)+import UnitTestHelpers (stubItem)++itemDescriptionUnitTests :: TestTree+itemDescriptionUnitTests = testGroup "itemDescriptionUnitTests" $+  let testItemFull = ItemFull+        { itemBase = stubItem+          {+            jkind = IdentityObvious (toEnum 667)+          , jflavour = head $ zipPlain [Green]+          }+        , itemKindId = toEnum 667+        , itemKind = emptyMultiGroupItem+        , itemDisco = ItemDiscoFull emptyAspectRecord+        , itemSuspect = True+        }+  in+  [ testCase "testItem_viewItem_Blackx" $+      viewItem testItemFull {itemKind = emptyMultiGroupItem {isymbol = 'x'}}+      @?= attrChar2ToW32 Green 'x'+  , testCase "testItem_viewItem_Black!" $+      viewItem testItemFull {itemKind = emptyMultiGroupItem {isymbol = '!'}}+      @?= attrChar2ToW32 Green '!'+  , testCase "testItem_viewItemBenefitColored_isEquip_Greenx" $+      viewItemBenefitColored (EM.singleton (toEnum 42) (Benefit True 0 0 0 0)) (toEnum 42) testItemFull {itemKind = emptyMultiGroupItem {isymbol = 'x'}}+      @?= attrChar2ToW32 BrGreen 'x'+  , testCase "testItem_viewItemBenefitColored_isNotEquip_Redx" $+      viewItemBenefitColored (EM.singleton (toEnum 42) (Benefit False 0 0 0 0)) (toEnum 42) testItemFull {itemKind = emptyMultiGroupItem {isymbol = 'x'}}+      @?= attrChar2ToW32 BrRed 'x'+  ]
+ test/ItemKindUnitTests.hs view
@@ -0,0 +1,59 @@+module ItemKindUnitTests (itemKindUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Test.Tasty+import Test.Tasty.HUnit++import qualified Content.RuleKind+import           Game.LambdaHack.Common.Kind (emptyMultiGroupItem)+import           Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Content.RuleKind as RK+import qualified Game.LambdaHack.Definition.Ability as Ability++itemKindUnitTests :: TestTree+itemKindUnitTests = testGroup "itemKindUnitTests" $+  let standardSymbols = RK.ritemSymbols Content.RuleKind.standardRules+      customSymbols = emptyItemSymbolsUsedInEngine {rsymbolNecklace = '*'}++  in+  [ testCase "overlonginame_validateSingle_errs" $+      validateSingle standardSymbols+                     emptyMultiGroupItem { iname = "123456789012345678901234" }+      @?= ["iname longer than 23"]+  , testCase "shortEnoughiname_validateSingle_noErr" $+      validateSingle standardSymbols+                     emptyMultiGroupItem+      @?= []+  , testCase "equipableNoSlotxSymbol_validateSingle_errs" $+      validateSingle standardSymbols+                     emptyMultiGroupItem { iaspects = [ SetFlag Ability.Equipable ] }+      @?= ["EqpSlot not specified but Equipable or Meleeable and not a likely organ or necklace or template"]+  , testCase "equipableNoSlot,Symbol_validateSingle_noErr" $+      validateSingle standardSymbols+                     emptyMultiGroupItem { isymbol = ','+                                  , iaspects = [ SetFlag Ability.Equipable ] }+      @?= []+  , testCase "equipableNoSlot\"Symbol_validateSingle_noErr" $+      validateSingle standardSymbols+                     emptyMultiGroupItem { isymbol = '"'+                                  , iaspects = [ SetFlag Ability.Equipable ] }+      @?= []+  , testCase "equipableNoSlot/Symbol_validateSingle_noErr" $+      validateSingle standardSymbols+                     emptyMultiGroupItem { isymbol = '/'+                                  , iaspects = [ SetFlag Ability.Equipable ] }+      @?= []+  , testCase "equipableNoSlot*CustomRules_validateSingle_noErr" $+      validateSingle customSymbols+                     emptyMultiGroupItem { isymbol = '*'+                                  , iaspects = [ SetFlag Ability.Equipable ] }+      @?= []+  , testCase "equipableNoSlot\"CustomRules_validateSingle_errs" $+      validateSingle customSymbols+                     emptyMultiGroupItem { isymbol = '"'+                                  , iaspects = [ SetFlag Ability.Equipable ] }+      @?= ["EqpSlot not specified but Equipable or Meleeable and not a likely organ or necklace or template"]+  ]
+ test/ItemRevUnitTests.hs view
@@ -0,0 +1,58 @@+module ItemRevUnitTests (itemRevUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Monad.Trans.State.Strict as St+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified Data.Vector.Unboxed as U+import qualified System.Random.SplitMix32 as SM+import           Test.Tasty+import           Test.Tasty.HUnit++import Game.LambdaHack.Common.Kind (emptyMultiGroupItem)+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Core.Random+import Game.LambdaHack.Definition.Color+import Game.LambdaHack.Definition.DefsInternal+import Game.LambdaHack.Definition.Flavour+import Game.LambdaHack.Server.ItemRev++itemRevUnitTests :: TestTree+itemRevUnitTests = testGroup "itemRevUnitTests" $+  let testItemKind2Flavours = emptyMultiGroupItem+        { iflavour = zipStory [Black,Green] }+      emptyIdToFlavourSymbolToFlavourSetPair = ( EM.empty, EM.empty )+      singletonIdToFlavourSymbolToFlavourSetPair =+        ( EM.singleton (toContentId 0) dummyFlavour+        , EM.singleton 'x' (ES.singleton dummyFlavour) )+      flavourBlack = head $ zipStory [Black]+      flavourGreen = head $ zipStory [Green]+  in+  [ testCase "empty & default initializers -> first is single dummy result" $+      let rndMapPair0 = return emptyIdToFlavourSymbolToFlavourSetPair+          mapPair1 = St.evalState (rollFlavourMap U.empty rndMapPair0 (toContentId 0) emptyMultiGroupItem) $ SM.mkSMGen 1+        in fst mapPair1 @?= EM.singleton (toContentId 0) dummyFlavour+  , testCase "empty & default initializers -> second is empty" $+      let rndMapPair0 = return emptyIdToFlavourSymbolToFlavourSetPair+          (mapPair1, _) = St.runState (rollFlavourMap U.empty rndMapPair0 (toContentId 0) emptyMultiGroupItem) $ SM.mkSMGen 1+        in snd mapPair1 @?= EM.empty+  , testCase "singleton initializers -> first is single dummy result" $+      let rndMapPair0 = return singletonIdToFlavourSymbolToFlavourSetPair+          (mapPair1, _) = St.runState (rollFlavourMap U.empty rndMapPair0 (toContentId 0) emptyMultiGroupItem) $ SM.mkSMGen 1+        in fst mapPair1 @?= EM.singleton (toContentId 0) dummyFlavour+  , testCase "singleton initializers -> second is single dummy result" $+      let rndMapPair0 = return singletonIdToFlavourSymbolToFlavourSetPair+          (mapPair1, _) = St.runState (rollFlavourMap U.empty rndMapPair0 (toContentId 0) emptyMultiGroupItem) $ SM.mkSMGen 1+        in snd mapPair1 @?= EM.singleton 'x' (ES.singleton dummyFlavour)+  , testCase "rollFlavourMap on two flavours -> first flavour can be rolled" $  -- relies on us not messing with RNG+      let rndMapPair0 = return singletonIdToFlavourSymbolToFlavourSetPair+          (mapPair1, _) = St.runState (rollFlavourMap (U.singleton invalidInformationCode) rndMapPair0 (toContentId 0) testItemKind2Flavours) $ SM.mkSMGen 1+        in fst mapPair1 @?= EM.singleton (toContentId 0) flavourBlack+  , testCase "rollFlavourMap on two flavours -> second flavour can be rolled" $  -- relies on us not messing with RNG+      let rndMapPair0 = return singletonIdToFlavourSymbolToFlavourSetPair+          (mapPair1, _) = St.runState (rollFlavourMap (U.singleton invalidInformationCode) rndMapPair0 (toContentId 0) testItemKind2Flavours) $ SM.mkSMGen 2+        in fst mapPair1 @?= EM.singleton (toContentId 0) flavourGreen+  ]
+ test/LevelUnitTests.hs view
@@ -0,0 +1,37 @@+module LevelUnitTests (levelUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.EnumMap.Strict as EM+import           Test.Tasty+import           Test.Tasty.HUnit++import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.State++import UnitTestHelpers (testLevel, testLevelId)++testDungeonWithLevel :: State+testDungeonWithLevel =+  let singletonDungeonUpdate _ = EM.singleton testLevelId testLevel+      unknownTileState = localFromGlobal emptyState+      oneLevelDungeonState =+        updateDungeon singletonDungeonUpdate unknownTileState+  in oneLevelDungeonState++levelUnitTests :: TestTree+levelUnitTests = testGroup "levelUnitTests"+  [ testCase "testDungeonWithLevel has min level id" $ do+      let ((minKey, _), _) =+            fromJust $ EM.minViewWithKey (sdungeon testDungeonWithLevel)+      minKey @?= testLevelId+  , testCase "testDungeonWithLevel has max level id" $ do+      let ((minKey, _), _) =+            fromJust $ EM.maxViewWithKey (sdungeon testDungeonWithLevel)+      minKey @?= testLevelId+  , testCase "dungeonBounds testDungeonWithLevel returns (0,0)" $ do+      let bounds = dungeonBounds (sdungeon testDungeonWithLevel)+      bounds @?= (testLevelId, testLevelId)+  ]
+ test/MonadClientUIUnitTests.hs view
@@ -0,0 +1,31 @@+module MonadClientUIUnitTests (monadClientUIUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Test.Tasty+import Test.Tasty.HUnit++import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.Overlay++import UnitTestHelpers++monadClientUIUnitTests :: TestTree+monadClientUIUnitTests = testGroup "handleHumanLocalMUnitTests"+  [ testCase "getsClient sside" $ do+      sideInMonad <- executorCli (getsClient sside) stubCliState+      fst sideInMonad @?= testFactionId+  , testCase "getArenaUI works in stub" $ do+      levelIdInMonad <- executorCli getArenaUI stubCliState+      fst levelIdInMonad @?= testLevelId+  , testCase "viewedLevelUI works in stub" $ do+      levelIdInMonad <- executorCli viewedLevelUI stubCliState+      fst levelIdInMonad @?= testLevelId+  , testCase "getFontSetup works in stub" $ do+      fontSetupInMonad <- executorCli getFontSetup stubCliState+      fst fontSetupInMonad @?= multiFontSetup+  ]
+ test/ReqFailureUnitTests.hs view
@@ -0,0 +1,55 @@+module ReqFailureUnitTests (reqFailureUnitTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import Test.Tasty+import Test.Tasty.HUnit++import qualified Content.RuleKind+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.ItemAspect+import           Game.LambdaHack.Common.Kind (emptyMultiGroupItem)+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Content.ItemKind+import           Game.LambdaHack.Definition.Defs+import           UnitTestHelpers (stubItem)++reqFailureUnitTests :: TestTree+reqFailureUnitTests = testGroup "reqFailureUnitTests" $+  let testItemFull = ItemFull+        { itemBase = stubItem -- Item { jkind = IdentityObvious (toEnum 667) , jfid = Nothing , jflavour = dummyFlavour}+        , itemKindId = toEnum 667+        , itemKind = emptyMultiGroupItem+        , itemDisco = ItemDiscoFull emptyAspectRecord+        , itemSuspect = True+        }+      standardRules = Content.RuleKind.standardRules+  in+  [ testCase "permittedApply: One Skill and x symbol -> FailureApplyFood" $+      permittedApply standardRules timeZero 1 True Nothing+                     testItemFull quantSingle+      @?= Left ApplyFood+  , testCase "permittedApply: One Skill and , symbol And CGround -> True" $+      permittedApply standardRules timeZero 1 True (Just CGround)+                     testItemFull {itemKind = emptyMultiGroupItem{isymbol = ','}}+                     quantSingle+      @?= Right True+  , testCase "permittedApply: One Skill and \" symbol -> True" $+      permittedApply standardRules timeZero 1 True Nothing+                     testItemFull {itemKind = emptyMultiGroupItem{isymbol = '"'}}+                     quantSingle+      @?= Right True+  , testCase "permittedApply: Two Skill and ? symbol -> FailureApplyRead" $+      permittedApply standardRules timeZero 2 True Nothing+                     testItemFull {itemKind = emptyMultiGroupItem{isymbol = '?'}}+                     quantSingle+      @?= Left ApplyRead+  , testCase "permittedApply: Two Skill and , symbol -> True" $+      permittedApply standardRules timeZero 2 True Nothing+                     testItemFull {itemKind = emptyMultiGroupItem{isymbol = ','}}+                     quantSingle+      @?= Right True+  ]
+ test/SessionUIMock.hs view
@@ -0,0 +1,150 @@+module SessionUIMock+  ( unwindMacros+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import           Control.Monad.Trans.Class+import           Control.Monad.Trans.State.Lazy+import           Control.Monad.Trans.Writer.Lazy+import           Data.Bifunctor (bimap)+import qualified Data.Map.Strict as M++import qualified Game.LambdaHack.Client.UI.Content.Input as IC+import           Game.LambdaHack.Client.UI.ContentClientUI+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.HandleHumanLocalM+import           Game.LambdaHack.Client.UI.HandleHumanM+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.SessionUI+  (KeyMacro (..), KeyMacroFrame (..), emptyMacroFrame)++data SessionUIMock = SessionUIMock+  { smacroFrame :: KeyMacroFrame+  , smacroStack :: [KeyMacroFrame]+  , sccui       :: CCUI+  , unwindTicks :: Int+  }++type KeyMacroBufferMock = Either String String+type KeyPendingMock = String+type KeyLastMock = String++type BufferTrace = [(KeyMacroBufferMock, KeyPendingMock, KeyLastMock)]+type ActionLog = String++data Op = Looped | HeadEmpty++humanCommandMock :: WriterT [(BufferTrace, ActionLog)] (State SessionUIMock) ()+humanCommandMock = do+  abuffs <- lift $ do+    sess <- get+    return $ renderTrace (smacroFrame sess : smacroStack sess)  -- log session+  abortOrCmd <- lift iterationMock -- do stuff+  -- GC macro stack if there are no actions left to handle,+  -- removing all unnecessary macro frames at once,+  -- but leaving the last one for user's in-game macros.+  lift $ modify $ \sess ->+          let (smacroFrameNew, smacroStackMew) =+                dropEmptyMacroFrames (smacroFrame sess) (smacroStack sess)+          in sess { smacroFrame = smacroFrameNew+                  , smacroStack = smacroStackMew }+  case abortOrCmd of+    Left Looped -> void $ tell [(abuffs, "Macro looped")]+    Left HeadEmpty -> void $ tell [(abuffs, "")]  -- exit loop+    Right Nothing -> tell [(abuffs, "")] >> humanCommandMock+    Right (Just out) -> tell [(abuffs, show out)] >> humanCommandMock++iterationMock :: State SessionUIMock (Either Op (Maybe K.KM))+iterationMock = do+  SessionUIMock _ _ CCUI{coinput=IC.InputContent{bcmdMap}} ticks <- get+  if ticks <= 1000+  then do+    modify $ \sess -> sess {unwindTicks = ticks + 1}+    mkm <- promptGetKeyMock+    case mkm of+      Nothing -> return $ Left HeadEmpty  -- macro finished+      Just km -> case km `M.lookup` bcmdMap of+        Just (_, _, cmd) -> Right <$> cmdSemInCxtOfKMMock km cmd+        _ -> return $ Right $ Just km  -- unknown command; fine for tests+  else return $ Left Looped++cmdSemInCxtOfKMMock :: K.KM -> HumanCmd.HumanCmd+                    -> State SessionUIMock (Maybe K.KM)+cmdSemInCxtOfKMMock km cmd = do+  modify $ \sess ->+    sess {smacroFrame = updateKeyLast km cmd $ smacroFrame sess}+  cmdSemanticsMock km cmd++cmdSemanticsMock :: K.KM -> HumanCmd.HumanCmd+                 -> State SessionUIMock (Maybe K.KM)+cmdSemanticsMock km = \case+  HumanCmd.Macro s -> do+    modify $ \sess ->+      let kms = K.mkKM <$> s+          (smacroFrameNew, smacroStackMew) =+             macroHumanTransition kms (smacroFrame sess) (smacroStack sess)+      in sess { smacroFrame = smacroFrameNew+              , smacroStack = smacroStackMew }+    return Nothing+  HumanCmd.Repeat n -> do+    modify $ \sess ->+      let (smacroFrameNew, smacroStackMew) =+             repeatHumanTransition n (smacroFrame sess) (smacroStack sess)+      in sess { smacroFrame = smacroFrameNew+              , smacroStack = smacroStackMew }+    return Nothing+  HumanCmd.RepeatLast n -> do+    modify $ \sess ->+      sess {smacroFrame = repeatLastHumanTransition n (smacroFrame sess) }+    return Nothing+  HumanCmd.Record -> do+    modify $ \sess ->+      sess {smacroFrame = fst $ recordHumanTransition (smacroFrame sess) }+    return Nothing+  _ -> return $ Just km++promptGetKeyMock :: State SessionUIMock (Maybe K.KM)+promptGetKeyMock = do+  SessionUIMock macroFrame _ CCUI{coinput=IC.InputContent{bcmdMap}} _ <- get+  case keyPending macroFrame of+    KeyMacro (km : kms) -> do+        modify $ \sess ->+          sess {smacroFrame = (smacroFrame sess) {keyPending = KeyMacro kms}}+        modify $ \sess ->+          sess {smacroFrame = addToMacro bcmdMap km $ smacroFrame sess}+        return (Just km)+    KeyMacro [] -> return Nothing++unwindMacrosFull :: IC.InputContent -> KeyMacro -> [(BufferTrace, ActionLog)]+unwindMacrosFull coinput keyPending =+  let initSession = SessionUIMock+        { smacroFrame = emptyMacroFrame {keyPending}+        , smacroStack = []+        , sccui = emptyCCUI {coinput}+        , unwindTicks = 0 }+  in evalState (execWriterT humanCommandMock) initSession++accumulateActions :: [(BufferTrace, ActionLog)] -> [(BufferTrace, ActionLog)]+accumulateActions ba =+  let (buffers, actions) = unzip ba+      actionlog = concat <$> inits actions+  in if snd (last ba) == "Macro looped"+     then ba+     else zip buffers actionlog++unwindMacros :: IC.InputContent -> KeyMacro -> [(BufferTrace, ActionLog)]+unwindMacros coinput keyPending =+  accumulateActions $ unwindMacrosFull coinput keyPending++renderTrace :: [KeyMacroFrame] -> BufferTrace+renderTrace macroFrames =+  let buffers = bimap (concatMap K.showKM)+                      (concatMap K.showKM . unKeyMacro)+                . keyMacroBuffer <$> macroFrames+      pendingKeys = concatMap K.showKM . unKeyMacro . keyPending <$> macroFrames+      lastKeys = maybe "" K.showKM . keyLast <$> macroFrames+  in zip3 buffers pendingKeys lastKeys
+ test/SessionUIUnitTests.hs view
@@ -0,0 +1,312 @@+module SessionUIUnitTests (macroTests) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Map.Strict as M+import           Test.Tasty+import           Test.Tasty.HUnit+import           Test.Tasty.QuickCheck++import qualified Game.LambdaHack.Client.UI.Content.Input as IC+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.SessionUI++import qualified Client.UI.Content.Input as Content.Input++import SessionUIMock++-- Run @test -p "In-game" --quickcheck-verbose@ to verify that quickcheck+-- properties are not too often satisfied voidly.+macroTests :: TestTree+macroTests = testGroup "macroTests" $+  let coinput = IC.makeData Nothing Content.Input.standardKeysAndMouse+      stringToKeyMacro = KeyMacro . map (K.mkKM . (: []))+      listToKeyMacro = KeyMacro . map K.mkKM+      bindInput l input =+        let ltriple = M.fromList $ map (\(k, ks) ->+              (K.mkKM k, ([], "", HumanCmd.Macro $ map (: []) ks))) l+        in input {IC.bcmdMap = M.union ltriple $ IC.bcmdMap input}+  in [ testCase "Macro 1 from PR#192 description" $+         fst <$> unwindMacros coinput (stringToKeyMacro "'j''j'")+         @?= [ [ (Right "",     "'j''j'",  "")  ]+             , [ (Left  "",     "j''j'",   "") ]+             , [ (Left  "j",    "''j'",    "j") ]+             , [ (Right "j",    "'j'",     "j") ]+             , [ (Left  "",     "j'",      "j") ]+             , [ (Left  "j",    "'",       "j") ]+             , [ (Right "j",    "",        "j") ]+             ]+     , testCase "Macro 1 from Issue#189 description" $+         snd (last (unwindMacros (bindInput [ ("a", "'bc'V")+                                            , ("c", "'aaa'V") ] coinput)+                                 (stringToKeyMacro "a")))+         @?= "Macro looped"+     , testCase "Macro 2 from Issue#189 description" $+         snd (last (unwindMacros (bindInput [("a", "'x'")] coinput)+                                 (stringToKeyMacro "'a'")))+         @?= "x"+     , testCase "Macro 3 from Issue#189 description" $+         snd (last (unwindMacros coinput+                                 (stringToKeyMacro "'x''x'")))+         @?= "xx"+     , testCase "Macro 4 from Issue#189 description" $+         snd (last (unwindMacros coinput+                                 (stringToKeyMacro "'x''x'V")))+         @?= "xxx"+     , testCase "Macro 5 from Issue#189 description" $+         snd (last (unwindMacros coinput+                                 (stringToKeyMacro "x'x'V")))+         @?= "xxx"+     , testCase "Macro test 10" $+         snd (last (unwindMacros coinput+                                 (stringToKeyMacro "x'y'V")))+         @?= "xyy"+     , testCase "Macro test 11" $+         snd (last (unwindMacros coinput+                                 (stringToKeyMacro "'x''y'V")))+         @?= "xyy"+     , testCase "Macro test 12" $+         snd (last (unwindMacros coinput+                                 (listToKeyMacro ["x", "C-V"])))+         @?= "x"+     , testCase "Macro test 13" $+         snd (last (unwindMacros coinput+                                 (listToKeyMacro ["'", "x", "'", "C-V"])))+         @?= "xxxxxxxxxxxxxxxxxxxxxxxxxx"+     , testCase "Macro test 14" $+         snd (last (unwindMacros coinput+                                 (listToKeyMacro ["'", "x", "'", "y", "C-V"])))+         @?= "xyxxxxxxxxxxxxxxxxxxxxxxxxx"+     , testCase "Macro test 15" $+         snd (last (unwindMacros (bindInput [("a", "x")] coinput)+                                 (stringToKeyMacro "'a'V")))+         @?= "xx"+     , testCase "Macro test 16" $+         snd (last (unwindMacros (bindInput [("a", "'x'")] coinput)+                                 (stringToKeyMacro "'a'V")))+         @?= "xx"+     , testCase "Macro test 17" $+         snd (last (unwindMacros (bindInput [("a", "'x'V")] coinput)+                                 (stringToKeyMacro "a")))+         @?= "xx"+     , testCase "Macro test 18" $+         snd (last (unwindMacros (bindInput [("a", "'x'V")] coinput)+                                 (stringToKeyMacro "'a'")))+         @?= "xx"+     , testCase "Macro test 19" $+         snd (last (unwindMacros (bindInput [("a", "'x'V")] coinput)+                                 (stringToKeyMacro "'a'V")))+         @?= "xxxx"+     , testCase "Macro test 20" $+         snd (last (unwindMacros (bindInput [ ("a", "'bz'V")+                                            , ("c", "'aaa'V") ] coinput)+                                 (stringToKeyMacro "c")))+         @?= "bzbzbzbzbzbzbzbzbzbzbzbz"+     , testCase "RepeatLast test 10" $+         snd (last (unwindMacros coinput+                                 (stringToKeyMacro "x'y'v")))+         @?= "xyy"+     , testCase "RepeatLast test 11" $+         snd (last (unwindMacros coinput+                                 (stringToKeyMacro "'x'yv")))+         @?= "xyy"+     , testCase "RepeatLast test 12" $+         snd (last (unwindMacros coinput+                                 (listToKeyMacro ["v", "C-v"])))+         @?= ""+     , testCase "RepeatLast test 13" $+         snd (last (unwindMacros coinput+                                 (listToKeyMacro ["'", "x", "'", "C-v"])))+         @?= "xxxxxxxxxxxxxxxxxxxxxxxxxx"+     , testCase "RepeatLast test 14" $+         snd (last (unwindMacros coinput+                                 (listToKeyMacro ["'", "x", "'", "V", "C-v"])))+         @?= "xxxxxxxxxxxxxxxxxxxxxxxxxxx"+     , testCase "RepeatLast test 15" $+         snd (last (unwindMacros (bindInput [("a", "x")] coinput)+                                 (stringToKeyMacro "av")))+         @?= "xx"+     , testCase "RepeatLast test 16" $+         snd (last (unwindMacros (bindInput [("a", "'x'")] coinput)+                                 (stringToKeyMacro "'a'v")))+         @?= "xx"+     , testCase "RepeatLast test 17" $+         snd (last (unwindMacros (bindInput [("a", "'x'v")] coinput)+                                 (stringToKeyMacro "a")))+         @?= "xx"+     , testCase "RepeatLast test 18" $+         snd (last (unwindMacros (bindInput [("a", "'x'v")] coinput)+                                 (stringToKeyMacro "'a'")))+         @?= "xx"+     , testCase "RepeatLast test 19" $+         snd (last (unwindMacros (bindInput [("a", "'x'v")] coinput)+                                 (stringToKeyMacro "'a'v")))+         @?= "xxxx"+     , testCase "RepeatLast test 20" $+         snd (last (unwindMacros (bindInput [ ("a", "'bz'v")+                                            , ("c", "'aaa'v") ] coinput)+                                 (stringToKeyMacro "c")))+         @?= "bzzbzzbzzbzz"+     , testCase "RepeatLast test 21" $+         snd (last (unwindMacros (bindInput [("a", "'x'V")] coinput)+                                 (stringToKeyMacro "'a'v")))+         @?= "xxxx"+     , testCase "RepeatLast test 22" $+         snd (last (unwindMacros (bindInput [("a", "'xy'V")] coinput)+                                 (stringToKeyMacro "'aa'v")))+         @?= "xyxyxyxyxyxy"+     , testCase "RepeatLast test 23" $+         snd (last (unwindMacros (bindInput [("a", "'xy'v")] coinput)+                                 (stringToKeyMacro "'aa'V")))+         @?= "xyyxyyxyyxyy"+     , testCase "RepeatLast test 24" $+         snd (last (unwindMacros (bindInput [("a", "'xy'vv")] coinput)+                                 (stringToKeyMacro "'aa'vv")))+         @?= "xyyyxyyyxyyyxyyy"+     , testCase "RepeatLast test 25" $+         snd (last (unwindMacros (bindInput [("a", "'xyv'v")] coinput)+                                 (stringToKeyMacro "'a'a'vv'")))+         @?= "xyyyxyyyxyyyxyyy"+     , testCase "RepeatLast test 26" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "'za'v")+                                            , ("c", "'ab'v") ] coinput)+                                 (stringToKeyMacro "'c'v")))+         @?= "xyyzxyyxyyzxyyxyyxyyzxyyxyyzxyyxyy"+     , testCase "RepeatLast test 27" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'V")+                                            , ("b", "'za'v")+                                            , ("c", "'ab'v") ] coinput)+                                 (stringToKeyMacro "'c'v")))+         @?= "xyxyzxyxyxyxyzxyxyxyxyxyxyzxyxyxyxyzxyxyxyxy"+     , testCase "RepeatLast test 28" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "'za'V")+                                            , ("c", "'ab'v") ] coinput)+                                 (stringToKeyMacro "'c'v")))+         @?= "xyyzxyyzxyyzxyyzxyyxyyzxyyzxyyzxyyzxyy"+     , testCase "RepeatLast test 29" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "'za'V")+                                            , ("c", "'ab'V") ] coinput)+                                 (stringToKeyMacro "'c'v")))+         @?= "xyyzxyyzxyyxyyzxyyzxyyxyyzxyyzxyyxyyzxyyzxyy"+     , testCase "RepeatLast test 30" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "'za'V")+                                            , ("c", "'ab'V") ] coinput)+                                 (stringToKeyMacro "'c'V")))+         @?= "xyyzxyyzxyyxyyzxyyzxyyxyyzxyyzxyyxyyzxyyzxyy"+     , testCase "RepeatLast test 31" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "'za'v")+                                            , ("c", "'ab'V") ] coinput)+                                 (stringToKeyMacro "'c'V")))+         @?= "xyyzxyyxyyxyyzxyyxyyxyyzxyyxyyxyyzxyyxyy"+     , testCase "RepeatLast test 32" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "'za'v") ] coinput)+                                 (stringToKeyMacro "'ab'vv")))+         @?= "xyyzxyyxyyzxyyxyyzxyyxyy"+     , testCase "RepeatLast test 33" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'V") ] coinput)+                                 (stringToKeyMacro "a'za'vvv")))+         @?= "xyxyzxyxyxyxyxyxyxyxy"+     , testCase "RepeatLast test 34" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("c", "a'za'Vv") ] coinput)+                                 (stringToKeyMacro "'c'v")))+         @?= "xyyzxyyzxyyzxyyxyyzxyyzxyyzxyy"+     , testCase "RepeatLast test 35" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "'za'V") ] coinput)+                                 (stringToKeyMacro "'ab'Vv")))+         @?= "xyyzxyyzxyyxyyzxyyzxyyxyyzxyyzxyy"+     , testCase "RepeatLast test 36" $+         snd (last (unwindMacros (bindInput [ ("a", "'xy'v")+                                            , ("b", "za'za'") ] coinput)+                                 (stringToKeyMacro "'ab'V'ab'V")))+         @?= "xyyzxyyzxyyxyyzxyyzxyyxyyzxyyzxyyxyyzxyyzxyy"+     , testCase "RepeatLast test 37" $+         snd (last (unwindMacros (bindInput [ ("b", "z'xy'vv")+                                            , ("c", "'xyvb'V") ] coinput)+                                 (stringToKeyMacro "'c'V")))+         @?= "xyyzxyyyxyyzxyyyxyyzxyyyxyyzxyyy"+     , testCase "RepeatLast test 38" $+         snd (last (unwindMacros coinput (stringToKeyMacro "'xv'V")))+         @?= "xxxx"+     , testCase "RepeatLast test 39" $+         fst <$> unwindMacros coinput (stringToKeyMacro "'xv'V")+         @?= [[(Right   "", "'xv'V",  "")],+              [(Left    "",  "xv'V",  "")],+              [(Left   "x",   "v'V", "x")],+              [(Left   "x",   "x'V", "x")],+              [(Left  "xx",    "'V", "x")],+              [(Right "xx",     "V", "x")],+              [(Right   "",    "xx",  ""), (Right "xx",    "", "V")],+              [(Right   "",     "x", "x"), (Right "xx",    "", "V")],+              [(Right "xx",      "", "V")]]+     , testCase "RepeatLast test 40" $+         snd (last (unwindMacros coinput (stringToKeyMacro "'xy'Vv")))+         @?= "xyxyxy"+     , testCase+         "RepeatLast test 41; named macros not referentially transparent" $+         snd (last (unwindMacros (bindInput [("a", "'xy'V")] coinput)+                                 (stringToKeyMacro "av")))+         @?= "xyxyxyxy"  -- because @a@ repeated; good!+     , testCase "RepeatLast test 42" $+         snd (last (unwindMacros (bindInput [("a", "xy")] coinput)+                                 (stringToKeyMacro "'a'Vv")))+         @?= "xyxyxy"  -- because @V@ repeated; good!+     , testCase "RepeatLast test 43" $+         snd (last (unwindMacros coinput (stringToKeyMacro "'xyV'V")))+         @?= "xyxy"+     , testCase "RepeatLast test 44" $+         snd (last (unwindMacros coinput (stringToKeyMacro "'xyV'v")))+         @?= "xyxy"+     , testCase "RepeatLast test 45" $+         snd (last (unwindMacros (bindInput [("a", "xyV")] coinput)+                                 (stringToKeyMacro "'a'V")))+         @?= "xyxy"+     , testCase "RepeatLast test 46" $+         snd (last (unwindMacros (bindInput [("a", "xyV")] coinput)+                                 (stringToKeyMacro "'a'v")))+         @?= "xyxy"+     , testProperty "In-game macro and equivalent predefined macro agree" $+         forAll (listOf (elements "`ABvV")) $+           \macro ->+             let bindings = bindInput [("a", macro)] coinput+                 inGameResult =+                   snd (last (unwindMacros coinput+                                           (stringToKeyMacro macro)))+             in inGameResult+                === snd (last (unwindMacros bindings+                                            (stringToKeyMacro "a")))+                .&&. inGameResult =/= "Macro looped"  -- may not loop+     , testProperty "In-game and predefined with limited minimal bindings" $+         forAll (listOf (elements "````''''ABCABCABCABCvVvVvVa")) $  -- may loop+           \macro ->+             let bindings = bindInput [("a", macro)] coinput+             in snd (last (unwindMacros bindings+                                        (stringToKeyMacro macro)))+                === snd (last (unwindMacros bindings+                                            (stringToKeyMacro "a")))+     , testProperty "In-game and predefined with limited multiple bindings" $+         forAll (listOf (elements "```ABCDvVabccc")) $+           \macro ->+             -- The macros may still loop due to mutual recursion,+             -- even though direct recursion is ruled out by filtering.+             let macroA = filter (/= 'a') macro+                 macroB = filter (/= 'b') $ take 5 $ reverse macro+                 bindings = bindInput [ ("a", macroA)+                                      , ("b", macroB)+                                      , ("c", "A'B''CD'") ]+                                      coinput+             in snd (last (unwindMacros bindings+                                        (stringToKeyMacro macroA)))+                === snd (last (unwindMacros bindings+                                            (stringToKeyMacro "a")))+     ]
+ test/Spec.hs view
@@ -0,0 +1,81 @@+module Main (main) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Data.Text as T+import           Options.Applicative+import           System.IO.Unsafe (unsafePerformIO)+import           Test.Tasty+import           Test.Tasty.HUnit++import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Client.UI.UIOptionsParse+import           Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Content.RuleKind as RK+import           Game.LambdaHack.Server++import qualified Content.RuleKind+import           TieKnot++import ActorStateUnitTests+import CommonMUnitTests+import HandleHelperMUnitTests+import HandleHumanLocalMUnitTests+import InventoryMUnitTests+import ItemDescriptionUnitTests+import ItemKindUnitTests+import ItemRevUnitTests+import LevelUnitTests+import MonadClientUIUnitTests+import ReqFailureUnitTests+import SessionUIUnitTests++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [ actorStateUnitTests+                          , commonMUnitTests+                          , handleHelperMUnitTests+                          , handleHumanLocalMUnitTests+                          , inventoryMUnitTests+                          , itemDescriptionUnitTests+                          , itemKindUnitTests+                          , itemRevUnitTests+                          , levelUnitTests+                          , reqFailureUnitTests+                          , macroTests+                          , monadClientUIUnitTests+                          , integrationTests+                          ]++integrationTests :: TestTree+integrationTests = testGroup "integrationTests" $+  [ testCase "Null frontend; 5 frames" $ do+      let seed = "SMGen 131 141"+          args = words "--dbgMsgSer --logPriority 4 --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 5 --automateAll --keepAutomated --gameMode crawl"+                 ++ [ "--setDungeonRng", seed, "--setMainRng", seed]+      serverOptions <- handleParseResult $ execParserPure defaultPrefs serverOptionsPI args+      tieKnot serverOptions+  ]+#ifndef USE_BROWSER+  +++  let corule = RK.makeData Content.RuleKind.standardRules+      uiOptions = unsafePerformIO $ mkUIOptions corule defClientOptions+      testFontset :: Int -> String -> TestTree+      testFontset n fontsetName =+        testCase ("SDL frontend; init only; " ++ fontsetName ++ " fontset") $ do+          -- This test only works when run from the same directory that+          -- the .cabal file is in. And this is what Debian needs, so OK.+          -- The hacky log priority 0 tells SDL frontend to init+          -- and quit at once, for testing on CIs without graphics access.+          let seed = "SMGen " ++ show (13 + 2 * n) ++ " " ++ show (15 + 4 * n)+              args2 = words "--dbgMsgSer --logPriority 0 --newGame 3 --maxFps 100000 --benchmark --stopAfterFrames 5 --automateAll --keepAutomated --gameMode battle"+                      ++ [ "--setDungeonRng", seed, "--setMainRng", seed+                         , "--fontset", fontsetName ]+          serverOptions2 <- handleParseResult $ execParserPure defaultPrefs serverOptionsPI args2+          tieKnot serverOptions2+  in zipWith testFontset [0..] $ map (T.unpack . fst) $ uFontsets uiOptions+#endif
+ test/UnitTestHelpers.hs view
@@ -0,0 +1,384 @@+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}+-- | Monadic test harness and other stubs for unit tests.+module UnitTestHelpers+  ( CliState(..)+  , emptyCliState+  , executorCli+  , reportToTexts+  , stubLevel+  , stubState+  , stubCliState+  , stubItem+  , testActor+  , testActorId+  , testActorWithItem+  , testCliStateWithItem+  , testFactionId+  , testItemId+  , testLevel+  , testLevelId+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , fchanFrontendStub+  , CliMock(..)+#endif+  ) where++import Prelude ()++import Game.LambdaHack.Core.Prelude++import qualified Control.Monad.IO.Class as IO+import           Control.Monad.Trans.State.Strict+  (StateT (StateT, runStateT), gets, state)+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as Text++import           Game.LambdaHack.Atomic (MonadStateWrite (..))+import           Game.LambdaHack.Client+import qualified Game.LambdaHack.Client.BfsM as BfsM+import           Game.LambdaHack.Client.HandleResponseM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+  (StateClient (..), TGoal (..), Target (..), emptyStateClient, updateLeader)+import           Game.LambdaHack.Client.UI+  (MonadClientUI (..), SessionUI (..), emptySessionUI)+import           Game.LambdaHack.Client.UI.ActorUI (ActorUI (..))+import           Game.LambdaHack.Client.UI.Content.Screen+  (emptyScreenContent, rheight, rwidth)+import           Game.LambdaHack.Client.UI.ContentClientUI (coscreen, emptyCCUI)+import           Game.LambdaHack.Client.UI.Frontend+  (ChanFrontend (..), FrontReq (..))+import           Game.LambdaHack.Client.UI.Key (KMP (..))+import qualified Game.LambdaHack.Client.UI.Key as K+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.PointUI (PointUI (..))+import           Game.LambdaHack.Client.UI.UIOptions (UIOptions (..))+import           Game.LambdaHack.Common.Actor+  (Actor (..), ResDelta (..), Watchfulness (..))+import           Game.LambdaHack.Common.Area (Area, toArea, trivialArea)+import           Game.LambdaHack.Common.ClientOptions+  (ClientOptions (..), FullscreenMode (..), defClientOptions)+import           Game.LambdaHack.Common.Faction (Faction (..))+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Kind (COps (..), emptyUIFaction)+import           Game.LambdaHack.Common.Level (Level (..))+import           Game.LambdaHack.Common.Misc (FontSet (..))+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception (emptyPer)+import           Game.LambdaHack.Common.Point (Point (..))+import           Game.LambdaHack.Common.State+  ( State+  , emptyState+  , unknownTileMap+  , updateActorD+  , updateActorMaxSkills+  , updateCOpsAndCachedData+  , updateDungeon+  , updateFactionD+  )+import           Game.LambdaHack.Common.Time (timeZero)+import           Game.LambdaHack.Common.Types+  (ActorId, FactionId, ItemId, LevelId)+import           Game.LambdaHack.Content.RuleKind (RuleContent (..))+import           Game.LambdaHack.Content.TileKind (unknownId)+import qualified Game.LambdaHack.Core.Dice as Dice+import qualified Game.LambdaHack.Definition.Ability as Ability+import           Game.LambdaHack.Definition.Color (Color (..))+import           Game.LambdaHack.Definition.DefsInternal (toContentId)+import           Game.LambdaHack.Definition.Flavour++-- * UI frontend stub++-- Read UI requests from the client and send them to the frontend,+fchanFrontendStub :: ChanFrontend+fchanFrontendStub =+  ChanFrontend $ \case+    FrontFrame _ -> putStr "FrontFrame"+    FrontDelay _ -> putStr "FrontDelay"+    FrontKey _ _ -> return KMP {kmpKeyMod = K.escKM, kmpPointer = PointUI 0 0}+    FrontPressed -> return False+    FrontDiscardKey -> putStr "FrontDiscardKey"+    FrontResetKeys -> putStr "FrontResetKeys"+    FrontShutdown -> putStr "FrontShutdown"+    FrontPrintScreen -> putStr "FrontPrintScreen"++-- * Mock client state implementation++data CliState = CliState+  { cliState   :: State            -- ^ current global state+  , cliClient  :: StateClient      -- ^ current client state+  , cliSession :: Maybe SessionUI  -- ^ UI state, empty for AI clients++  -- Not needed for the mock monad (and blank line needed to avoid making this+  -- comment a haddock for @cliSession@ field):+  -- , cliDict    :: ChanServer+  -- , cliToSave  :: Save.ChanSave (StateClient, Maybe SessionUI)+  }++-- * Option stubs++stubUIOptions :: UIOptions+stubUIOptions = UIOptions+  { uCommands = []+  , uHeroNames = []+  , uVi = False+  , uLeftHand = False+  , uChosenFontset = ""+  , uAllFontsScale = 0.0+  , uFullscreenMode = NotFullscreen+  , uhpWarningPercent = 0+  , uMsgWrapColumn = 0+  , uHistoryMax = 0+  , uMaxFps = 0.0+  , uNoAnim = False+  , uOverrideCmdline = []+  , uFonts = []+  , uFontsets = []+  , uMessageColors = []+  }++stubClientOptions :: ClientOptions+stubClientOptions = defClientOptions+  { schosenFontset = Just "snoopy"+  , sfontsets =+      [("snoopy", FontSet { fontMapScalable = "scalable"+                          , fontMapBitmap = "bitmap"+                          , fontPropRegular = "propRegular"+                          , fontPropBold = "propBold"+                          , fontMono = "mono" })]+  }++stubItem :: Item+stubItem = Item { jkind = IdentityObvious (toContentId 0), jfid = Nothing, jflavour = dummyFlavour }++testLevel :: Level+testLevel = Level+  { lkind = toEnum 0+  , ldepth = Dice.AbsDepth 1+  , lfloor = EM.empty+  , lembed = EM.empty+  , lbig = EM.empty+  , lproj = EM.empty+  , ltile = unknownTileMap (fromJust (toArea (0,0,0,0))) unknownId 10 10  --PointArray.empty+  , lentry = EM.empty+  , larea = trivialArea (Point 0 0)+  , lsmell = EM.empty+  , lstair = ([],[])+  , lescape = []+  , lseen = 0+  , lexpl = 0+  , ltime = timeZero+  , lnight = False+  }++-- * Stub identifiers++-- Using different arbitrary numbers for these so that if tests fail+-- due to missing keys we'll have more of a clue.+testLevelId :: LevelId+testLevelId = toEnum 111++testActorId :: ActorId+testActorId = toEnum 112++testItemId :: ItemId+testItemId = toEnum 113++testFactionId :: FactionId+testFactionId = toEnum 114++-- * Game arena element stubs++testArea :: Area+testArea = fromJust(toArea (0, 0, 0, 0))++testLevelDimension :: Int+testLevelDimension = 3++stubLevel :: Level+stubLevel = Level+  { lkind = toEnum 0+  , ldepth = Dice.AbsDepth 1+  , lfloor = EM.empty+  , lembed = EM.empty+  , lbig = EM.empty+  , lproj = EM.empty+  , ltile = unknownTileMap testArea unknownId testLevelDimension testLevelDimension+  , lentry = EM.empty+  , larea = trivialArea (Point 0 0)+  , lsmell = EM.empty+  , lstair = ([],[])+  , lescape = []+  , lseen = 0+  , lexpl = 0+  , ltime = timeZero+  , lnight = False+  }+testFaction :: Faction+testFaction =+  Faction+    { gkind = emptyUIFaction+    , gname = ""+    , gcolor = Black+    , gdoctrine = Ability.TBlock+    , gunderAI = True+    , ginitial = []+    , gdipl = EM.empty+    , gquit = Nothing+    , _gleader = Nothing+    , gstash = Nothing+    , gvictims = EM.empty+    }++testActor :: Actor+testActor = Actor+  { btrunk = testItemId+  , bnumber = Nothing+  , bhp = 0+  , bhpDelta = ResDelta (0,0) (0,0)+  , bcalm = 0+  , bcalmDelta = ResDelta (0,0) (0,0)+  , bpos = Point 0 0+  , boldpos = Nothing+  , blid = testLevelId+  , bfid = testFactionId+  , btrajectory = Nothing+  , borgan = EM.empty+  , beqp = EM.empty+  , bweapon = 0+  , bweapBenign = 0+  , bwatch = WWatch+  , bproj = False+  }++testActorWithItem :: Actor+testActorWithItem =+  testActor { beqp = EM.singleton testItemId (1,[])}++-- Stublike state that should barely function for testing.+stubState :: State+stubState =+  let singletonFactionUpdate _ = EM.singleton testFactionId testFaction+      singletonDungeonUpdate _ = EM.singleton testLevelId stubLevel+      singletonActorDUpdate _ = EM.singleton testActorId testActor+      singletonActorMaxSkillsUpdate _ =+        EM.singleton testActorId Ability.zeroSkills+      copsUpdate oldCOps =+        oldCOps {corule = (corule oldCOps)+                   { rWidthMax = testLevelDimension+                   , rHeightMax = testLevelDimension }}+      stateWithMaxLevelDimension = updateCOpsAndCachedData copsUpdate emptyState+      stateWithFaction =+        updateFactionD singletonFactionUpdate stateWithMaxLevelDimension+      stateWithActorD = updateActorD singletonActorDUpdate stateWithFaction+      stateWithActorMaxSkills =+        updateActorMaxSkills singletonActorMaxSkillsUpdate stateWithActorD+      stateWithDungeon =+        updateDungeon singletonDungeonUpdate stateWithActorMaxSkills+  in stateWithDungeon++testStateWithItem :: State+testStateWithItem =+  let swapToItemActor _ = EM.singleton testActorId testActorWithItem+  in updateActorD swapToItemActor stubState++emptyCliState :: CliState+emptyCliState = CliState+  { cliState = emptyState+  , cliClient = emptyStateClient testFactionId+  , cliSession = Nothing+  }++stubSessionUI :: SessionUI+stubSessionUI =+  let actorUI = ActorUI { bsymbol = 'j'+                        , bname = "Jamie"+                        , bpronoun = "he/him"+                        , bcolor = BrCyan }+  in (emptySessionUI stubUIOptions)+    { sactorUI = EM.singleton testActorId actorUI+    , sccui = emptyCCUI { coscreen = emptyScreenContent+                                       { rwidth = testLevelDimension+                                       , rheight = testLevelDimension + 3 } }+    , schanF = fchanFrontendStub+    }++stubCliState :: CliState+stubCliState = CliState+  { cliState = stubState+  , cliClient = (emptyStateClient testFactionId)+      { soptions = stubClientOptions+      , sfper = EM.singleton testLevelId emptyPer }+  , cliSession = let target = TPoint TUnknown testLevelId (Point 1 0)+                 in Just (stubSessionUI {sxhair = Just target})+  }++testCliStateWithItem :: CliState+testCliStateWithItem = stubCliState { cliState = testStateWithItem }+++-- * Monad harness mock++-- | Client state transformation monad mock.+newtype CliMock a = CliMock+  { runCliMock :: StateT CliState IO a }+    -- we build off io so we can compile but we don't want to use it;+    -- TODO: let's try to get rid of the IO. I can't see any problem right now.+    -- We'd need to to define dummy liftIO in some monads, etc.+  deriving (Monad, Functor, Applicative)++instance MonadStateRead CliMock where+  {-# INLINE getsState #-}+  getsState f = CliMock $ gets $ f . cliState++instance MonadStateWrite CliMock where+  {-# INLINE modifyState #-}+  modifyState f = CliMock $ state $ \cliS ->+    let !newCliS = cliS {cliState = f $ cliState cliS}+    in ((), newCliS)+  {-# INLINE putState #-}+  putState newCliState = CliMock $ state $ \cliS ->+    let !newCliS = cliS {cliState = newCliState}+    in ((), newCliS)++instance MonadClientRead CliMock where+  {-# INLINE getsClient #-}+  getsClient f = CliMock $ gets $ f . cliClient+  liftIO = CliMock . IO.liftIO++instance MonadClient CliMock where+  {-# INLINE modifyClient #-}+  modifyClient f = CliMock $ state $ \cliS ->+    let !newCliS = cliS {cliClient = f $ cliClient cliS}+    in ((), newCliS)++instance MonadClientUI CliMock where+  {-# INLINE getsSession #-}+  getsSession f = CliMock $ gets $ f . fromJust . cliSession+  {-# INLINE modifySession #-}+  modifySession f = CliMock $ state $ \cliS ->+    let !newCliSession = f $ fromJust $ cliSession cliS+        !newCliS = cliS {cliSession = Just newCliSession}+    in ((), newCliS)+  updateClientLeader aid = do+    s <- getState+    modifyClient $ updateLeader aid s+  getCacheBfs = BfsM.getCacheBfs+  getCachePath = BfsM.getCachePath++instance MonadClientAtomic CliMock where+  {-# INLINE execUpdAtomic #-}+  execUpdAtomic _ = return ()  -- handleUpdAtomic, until needed, save resources+    -- Don't catch anything; assume exceptions impossible.+  {-# INLINE execPutState #-}+  execPutState = putState++executorCli :: CliMock a -> CliState -> IO (a, CliState)+executorCli = runStateT . runCliMock+++-- | Transform 'Report' type to a list of 'Text'.+reportToTexts :: Report -> [Text.Text]+reportToTexts report = Text.pack . attrStringToString <$> renderReport False report
− test/test.hs 
@@ -1,6 +0,0 @@-import TieKnot--main :: IO ()-main = do-  tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42"-  -- tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42"